Session Registers

Theory Axioms

section Axioms of registers

theory Axioms
  imports Main
begin

class domain
instance prod :: (domain,domain) domain
  by intro_classes

typedecl 'a update
axiomatization comp_update :: "'a::domain update  'a update  'a update" where
  comp_update_assoc: "comp_update (comp_update a b) c = comp_update a (comp_update b c)"
axiomatization id_update :: "'a::domain update" where
  id_update_left: "comp_update id_update a = a" and
  id_update_right: "comp_update a id_update = a"

axiomatization preregister :: ('a::domain update  'b::domain update)  bool
axiomatization where
  comp_preregister: "preregister F  preregister G  preregister (G  F)" and
  id_preregister: preregister id
for F :: 'a::domain update  'b::domain update and G :: 'b update  'c::domain update

axiomatization where
  preregister_mult_right: preregister (λa. comp_update a z) and
  preregister_mult_left: preregister (λa. comp_update z a)
    for z :: "'a::domain update"

axiomatization tensor_update :: 'a::domain update  'b::domain update  ('a×'b) update 
  where tensor_extensionality: "preregister F  preregister G  (a b. F (tensor_update a b) = G (tensor_update a b))  F = G"
  for F G :: ('a×'b) update  'c::domain update

axiomatization where tensor_update_mult: comp_update (tensor_update a c) (tensor_update b d) = tensor_update (comp_update a b) (comp_update c d)
  for a b :: 'a::domain update and c d :: 'b::domain update

axiomatization register :: ('a update  'b update)  bool
axiomatization where
  register_preregister: "register F  preregister F" and
  register_comp: "register F  register G  register (G  F)"  and
  register_mult: "register F  comp_update (F a) (F b) = F (comp_update a b)" and
  register_of_id: register F  F id_update = id_update and
  register_id: register (id :: 'a update  'a update)
for F :: "'a::domain update  'b::domain update" and G :: "'b update  'c::domain update" 

axiomatization where register_tensor_left: register (λa. tensor_update a id_update)
axiomatization where register_tensor_right: register (λa. tensor_update id_update a)

axiomatization register_pair ::
  ('a::domain update  'c::domain update)  ('b::domain update  'c update)
          (('a×'b) update  'c update) where
  register_pair_is_register: register F  register G  (a b. comp_update (F a) (G b) = comp_update (G b) (F a))
        register (register_pair F G) and
  register_pair_apply: register F  register G  (a b. comp_update (F a) (G b) = comp_update (G b) (F a))
        (register_pair F G) (tensor_update a b) = comp_update (F a) (G b)

end

Theory Laws

section Generic laws about registers

theory Laws
  imports Axioms
begin

text This notation is only used inside this file
notation comp_update (infixl "*u" 55)
notation tensor_update (infixr "u" 70)
notation register_pair ("'(_;_')")

subsection Elementary facts

declare id_preregister[simp]
declare id_update_left[simp]
declare id_update_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]

subsection Preregisters

lemma preregister_tensor_left[simp]: preregister (λb::'b::domain update. tensor_update a b)
  for a :: 'a::domain update
proof -
  have preregister ((λb1::('a×'b) update. (a u id_update) *u b1) o (λb. tensor_update id_update b))
    by (rule comp_preregister; simp)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

lemma preregister_tensor_right[simp]: preregister (λa::'a::domain update. tensor_update a b)  
  for b :: 'b::domain update
proof -
  have preregister ((λa1::('a×'b) update. (id_update u b) *u a1) o (λa. tensor_update a id_update))
    by (rule comp_preregister, simp_all)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

subsection Registers

lemma id_update_tensor_register[simp]:
  assumes register F
  shows register (λa::'a::domain update. id_update u F a)
  using assms apply (rule register_comp[unfolded o_def])
  by simp

lemma register_tensor_id_update[simp]:
  assumes register F
  shows register (λa::'a::domain update. F a u id_update)
  using assms apply (rule register_comp[unfolded o_def])
  by simp

subsection Tensor product of registers

definition register_tensor  (infixr "r" 70) where
  "register_tensor F G = register_pair (λa. tensor_update (F a) id_update) (λb. tensor_update id_update (G b))"

lemma register_tensor_is_register: 
  fixes F :: "'a::domain update  'b::domain update" and G :: "'c::domain update  'd::domain update"
  shows "register F  register G  register (F r G)"
  unfolding register_tensor_def
  apply (rule register_pair_is_register)
  by (simp_all add: tensor_update_mult)

lemma register_tensor_apply[simp]:
  fixes F :: "'a::domain update  'b::domain update" and G :: "'c::domain update  'd::domain update"
  assumes register F and register G
  shows "(F r G) (a u b) = F a u G b"
  unfolding register_tensor_def
  apply (subst register_pair_apply)
  unfolding register_tensor_def 
  by (simp_all add: assms tensor_update_mult)

definition "separating (_::'b::domain itself) A  
  (F G :: 'a::domain update  'b update. preregister F  preregister G  (xA. F x = G x)  F = G)"

lemma separating_UNIV[simp]: separating TYPE(_) UNIV
  unfolding separating_def by auto

lemma separating_mono: A  B  separating TYPE('a::domain) A  separating TYPE('a) B
  unfolding separating_def by (meson in_mono) 

lemma register_eqI: separating TYPE('b::domain) A  preregister F  preregister G  (x. xA  F x = G x)  F = (G::_  'b update)
  unfolding separating_def by auto

lemma separating_tensor:
  fixes A :: 'a::domain update set and B :: 'b::domain update set
  assumes [simp]: separating TYPE('c::domain) A
  assumes [simp]: separating TYPE('c) B
  shows separating TYPE('c) {a u b | a b. aA  bB}
proof (unfold separating_def, intro allI impI)
  fix F G :: ('a×'b) update  'c update
  assume [simp]: preregister F preregister G
  have [simp]: preregister (λx. F (a u x)) for a
    using _ preregister F apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: preregister (λx. G (a u x)) for a
    using _ preregister G apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: preregister (λx. F (x u b)) for b
    using _ preregister F apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: preregister (λx. G (x u b)) for b
    using _ preregister G apply (rule comp_preregister[unfolded o_def])
    by simp

  assume x{a u b |a b. aA  bB}. F x = G x
  then have EQ: F (a u b) = G (a u b) if a  A and b  B for a b
    using that by auto
  then have F (a u b) = G (a u b) if a  A for a b
    apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
    using that by auto
  then have F (a u b) = G (a u b) for a b
    apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
    by auto
  then show "F = G"
    apply (rule tensor_extensionality[rotated -1])
    by auto
qed

lemma register_tensor_distrib:
  assumes [simp]: register F register G register H register L
  shows (F r G) o (H r L) = (F o H) r (G o L)
  apply (rule tensor_extensionality)
  by (auto intro!: register_comp register_preregister register_tensor_is_register)

text The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}
lemma separating_tensor':
  fixes A :: 'a::domain update set and B :: 'b::domain update set
  assumes separating TYPE('c::domain) A
  assumes separating TYPE('c) B
  assumes C = {a u b | a b. aA  bB}
  shows separating TYPE('c) C
  using assms
  by (simp add: separating_tensor)

lemma tensor_extensionality3: 
  fixes F G :: ('a::domain×'b::domain×'c::domain) update  'd::domain update
  assumes [simp]: register F register G
  assumes "f g h. F (f u g u h) = G (f u g u h)"
  shows "F = G"
proof (rule register_eqI[where A={aubuc| a b c. True}])
  have separating TYPE('d) {b u c |b c. True}
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show separating TYPE('d) {a u b u c |a b c. True}
    apply (rule_tac separating_tensor'[where A=UNIV and B={buc| b c. True}])
    by auto
  show preregister F preregister G by auto
  show x  {a u b u c |a b c. True}  F x = G x for x
    using assms(3) by auto
qed

lemma tensor_extensionality3': 
  fixes F G :: (('a::domain×'b::domain)×'c::domain) update  'd::domain update
  assumes [simp]: register F register G
  assumes "f g h. F ((f u g) u h) = G ((f u g) u h)"
  shows "F = G"
proof (rule register_eqI[where A={(aub)uc| a b c. True}])
  have separating TYPE('d) {a u b | a b. True}
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show separating TYPE('d) {(a u b) u c |a b c. True}
    apply (rule_tac separating_tensor'[where B=UNIV and A={aub| a b. True}])
    by auto
  show preregister F preregister G by auto
  show x  {(a u b) u c |a b c. True}  F x = G x for x
    using assms(3) by auto
qed

lemma register_tensor_id[simp]: id r id = id
  apply (rule tensor_extensionality)
  by (auto simp add: register_tensor_is_register)

subsection Pairs and compatibility

definition compatible :: ('a::domain update  'c::domain update)
                        ('b::domain update  'c update)  bool where
  compatible F G  register F  register G  (a b. F a *u G b = G b *u F a)

lemma compatibleI:
  assumes "register F" and "register G"
  assumes a b. (F a) *u (G b) = (G b) *u (F a)
  shows "compatible F G"
  using assms unfolding compatible_def by simp

lemma swap_registers:
  assumes "compatible R S"
  shows "R a *u S b = S b *u R a"
  using assms unfolding compatible_def by metis

lemma compatible_sym: "compatible x y  compatible y x"
  by (simp add: compatible_def)

lemma pair_is_register[simp]:
  assumes "compatible F G"
  shows "register (F; G)"
  by (metis assms compatible_def register_pair_is_register)

lemma register_pair_apply:
  assumes compatible F G
  shows (F; G) (a u b) = (F a) *u (G b)
  apply (rule register_pair_apply)
  using assms unfolding compatible_def by metis+

lemma register_pair_apply':
  assumes compatible F G
  shows (F; G) (a u b) = (G b) *u (F a)
  apply (subst register_pair_apply)
  using assms by (auto simp: compatible_def intro: register_preregister)



lemma compatible_comp_left[simp]: "compatible F G  register H  compatible (F  H) G"
  by (simp add: compatible_def)

lemma compatible_comp_right[simp]: "compatible F G  register H  compatible F (G  H)"
  by (simp add: compatible_def)

lemma compatible_comp_inner[simp]: 
  "compatible F G  register H  compatible (H  F) (H  G)"
  by (smt (verit, best) comp_apply compatible_def register_comp register_mult)

lemma compatible_register1: compatible F G  register F
  by (simp add: compatible_def)
lemma compatible_register2: compatible F G  register G
  by (simp add: compatible_def)

lemma pair_o_tensor:
  assumes "compatible A B" and [simp]: register C and [simp]: register D
  shows "(A; B) o (C r D) = (A o C; B o D)"
  apply (rule tensor_extensionality)
  using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)

lemma compatible_tensor_id_update_left[simp]:
  fixes F :: "'a::domain update  'c::domain update" and G :: "'b::domain update  'c::domain update"
  assumes "compatible F G"
  shows "compatible (λa. id_update u F a) (λa. id_update u G a)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_right[simp]:
  fixes F :: "'a::domain update  'c::domain update" and G :: "'b::domain update  'c::domain update"
  assumes "compatible F G"
  shows "compatible (λa. F a u id_update) (λa. G a u id_update)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_rl[simp]:
  assumes "register F" and "register G"
  shows "compatible (λa. F a u id_update) (λa. id_update u G a)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma compatible_tensor_id_update_lr[simp]:
  assumes "register F" and "register G"
  shows "compatible (λa. id_update u F a) (λa. G a u id_update)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma register_comp_pair:
  assumes [simp]: register F and [simp]: compatible G H
  shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
  show preregister (F  G;F  H) and preregister (F  (G;H))
    by simp_all

  have [simp]: compatible (F o G) (F o H)
    apply (rule compatible_comp_inner, simp)
    by simp
  then have [simp]: register (F  G) register (F  H)
    unfolding compatible_def by auto
  from assms have [simp]: register G register H
    unfolding compatible_def by auto
  fix a b
  show (F  G;F  H) (a u b) = (F  (G;H)) (a u b)
    by (auto simp: register_pair_apply register_mult tensor_update_mult)
qed

lemma swap_registers_left:
  assumes "compatible R S"
  shows "R a *u S b *u c = S b *u R a *u c"
  using assms unfolding compatible_def by metis

lemma swap_registers_right:
  assumes "compatible R S"
  shows "c *u R a *u S b = c *u S b *u R a"
  by (metis assms comp_update_assoc compatible_def)

lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right

subsection Fst and Snd

definition Fst where Fst a = a u id_update
definition Snd where Snd a = id_update u a

lemma register_Fst[simp]: register Fst
  unfolding Fst_def by (rule register_tensor_left)

lemma register_Snd[simp]: register Snd
  unfolding Snd_def by (rule register_tensor_right)

lemma compatible_Fst_Snd[simp]: compatible Fst Snd
  apply (rule compatibleI, simp, simp)
  by (simp add: Fst_def Snd_def tensor_update_mult)

lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]

definition swap = (Snd; Fst)

lemma swap_apply[simp]: "swap (a u b) = (b u a)"
  unfolding swap_def
  by (simp add: Axioms.register_pair_apply Fst_def Snd_def tensor_update_mult) 

lemma swap_o_Fst: "swap o Fst = Snd"
  by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
  by (auto simp add: Fst_def Snd_def)

lemma register_swap[simp]: register swap
  by (simp add: swap_def)

lemma pair_Fst_Snd: (Fst; Snd) = id
  apply (rule tensor_extensionality)
  by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma swap_o_swap[simp]: swap o swap = id
  by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)

lemma swap_swap[simp]: swap (swap x) = x
  by (simp add: pointfree_idE)

lemma inv_swap[simp]: inv swap = swap
  by (meson inv_unique_comp swap_o_swap)

lemma register_pair_Fst:
  assumes compatible F G
  shows (F;G) o Fst = F
  using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)

lemma register_pair_Snd:
  assumes compatible F G
  shows (F;G) o Snd = G
  using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)

lemma register_Fst_register_Snd[simp]:
  assumes register F
  shows (F o Fst; F o Snd) = F
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)

lemma register_Snd_register_Fst[simp]: 
  assumes register F
  shows (F o Snd; F o Fst) = F o swap
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)


lemma compatible3[simp]:
  assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible (F; G) H"
proof (rule compatibleI)
  have [simp]: register F register G register H
    using assms compatible_def by auto
  then have [simp]: preregister F preregister G preregister H
    using register_preregister by blast+
  have [simp]: preregister (λa. (F;G) a *u z) for z
    apply (rule comp_preregister[unfolded o_def, of (F;G)])
    by simp_all
  have [simp]: preregister (λa. z *u (F;G) a) for z
    apply (rule comp_preregister[unfolded o_def, of (F;G)])
    by simp_all
  have "(F; G) (f u g) *u H h = H h *u (F; G) (f u g)" for f g h
  proof -
    have FH: "F f *u H h = H h *u F f"
      using assms compatible_def by metis
    have GH: "G g *u H h = H h *u G g"
      using assms compatible_def by metis
    have (F; G) (f u g) *u (H h) = F f *u G g *u H h
      using compatible F G by (subst register_pair_apply, auto)
    also have  = H h *u F f *u G g
      using FH GH by (metis comp_update_assoc)
    also have  = H h *u (F; G) (f u g)
      using compatible F G by (subst register_pair_apply, auto simp: comp_update_assoc)
    finally show ?thesis
      by -
  qed
  then show "(F; G) fg *u (H h) = (H h) *u (F; G) fg" for fg h
    apply (rule_tac tensor_extensionality[THEN fun_cong])
    by auto
  show "register H" and  "register (F; G)"
    by simp_all
qed

lemma compatible3'[simp]:
  assumes "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible F (G; H)"
  apply (rule compatible_sym)
  apply (rule compatible3)
  using assms by (auto simp: compatible_sym)

lemma pair_o_swap[simp]:
  assumes [simp]: "compatible A B"
  shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
  have [simp]: "preregister A" "preregister B"
     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
    by (metis (full_types) assms compatible_register2 register_preregister)
  then show preregister ((A; B)  swap)
    by simp
  show preregister (B; A)
    by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
  show ((A; B)  swap) (a u b) = (B; A) (a u b) for a b
    (* Without the "only:", we would not need the "apply subst",
       but that proof fails when instantiated in Classical.thy *)
    apply (simp only: o_def swap_apply)
    apply (subst register_pair_apply, simp)
    apply (subst register_pair_apply, simp add: compatible_sym)
    by (metis (no_types, lifting) assms compatible_def)
qed


subsection Compatibility of register tensor products

lemma compatible_register_tensor:
  fixes F :: 'a::domain update  'e::domain update and G :: 'b::domain update  'f::domain update
    and F' :: 'c::domain update  'e update and G' :: 'd::domain update  'f update
  assumes [simp]: compatible F F'
  assumes [simp]: compatible G G'
  shows compatible (F r G) (F' r G')
proof -
  note [intro!] = 
    comp_preregister[OF _ preregister_mult_right, unfolded o_def]
    comp_preregister[OF _ preregister_mult_left, unfolded o_def]
    comp_preregister
    register_tensor_is_register
  have [simp]: register F register G register F' register G'
    using assms compatible_def by blast+
  have [simp]: register (F r G) register (F' r G')
    by (auto simp add: register_tensor_def)
  have [simp]: register (F;F') register (G;G')
    by auto
  define reorder :: (('a×'b) × ('c×'d)) update  (('a×'c) × ('b×'d)) update
    where reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))
  have [simp]: preregister reorder
    by (auto simp: reorder_def)
  have [simp]: reorder ((a u b) u (c u d)) = ((a u c) u (b u d)) for a b c d
    apply (simp add: reorder_def register_pair_apply)
    by (simp add: Fst_def Snd_def tensor_update_mult)
  define Φ where Φ c d = ((F;F') r (G;G')) o reorder o (λσ. σ u (c u d)) for c d
  have [simp]: preregister (Φ c d) for c d
    unfolding Φ_def 
    by (auto intro: register_preregister)
  have Φ c d (a u b) = (F r G) (a u b) *u (F' r G') (c u d) for a b c d
    unfolding Φ_def by (auto simp: register_pair_apply tensor_update_mult)
  then have Φ1: Φ c d σ = (F r G) σ *u (F' r G') (c u d) for c d σ
    apply (rule_tac fun_cong[of _ _ σ])
    apply (rule tensor_extensionality)
    by auto
  have Φ c d (a u b) = (F' r G') (c u d) *u (F r G) (a u b) for a b c d
    unfolding Φ_def apply (auto simp: register_pair_apply)
    by (metis assms(1) assms(2) compatible_def tensor_update_mult)
  then have Φ2: Φ c d σ = (F' r G') (c u d) *u (F r G) σ for c d σ
    apply (rule_tac fun_cong[of _ _ σ])
    apply (rule tensor_extensionality)
    by auto
  from Φ1 Φ2 have (F r G) σ *u (F' r G') τ = (F' r G') τ *u (F r G) σ for τ σ
    apply (rule_tac fun_cong[of _ _ τ])
    apply (rule tensor_extensionality)
    by auto
  then show ?thesis
    apply (rule compatibleI[rotated -1])
    by auto
qed

subsection Associativity of the tensor product

definition assoc :: (('a::domain×'b::domain)×'c::domain) update  ('a×('b×'c)) update where 
  assoc = ((Fst; Snd o Fst); Snd o Snd)

lemma assoc_is_hom[simp]: preregister assoc
  by (auto simp: assoc_def)

lemma assoc_apply[simp]: assoc ((a u b) u c) = (a u (b u c))
  by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)

definition assoc' :: ('a×('b×'c)) update  (('a::domain×'b::domain)×'c::domain) update where 
  assoc' = (Fst o Fst; (Fst o Snd; Snd))

lemma assoc'_is_hom[simp]: preregister assoc'
  by (auto simp: assoc'_def)

lemma assoc'_apply[simp]: assoc' (a u (b u c)) =  ((a u b) u c)
  by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma register_assoc[simp]: register assoc
  unfolding assoc_def
  by force

lemma register_assoc'[simp]: register assoc'
  unfolding assoc'_def 
  by force

lemma pair_o_assoc[simp]:
  assumes [simp]: compatible F G compatible G H compatible F H
  shows (F; (G; H))  assoc = ((F; G); H)
proof (rule tensor_extensionality3')
  show register ((F; (G; H))  assoc)
    by simp
  show register ((F; G); H)
    by simp
  show ((F; (G; H))  assoc) ((f u g) u h) = ((F; G); H) ((f u g) u h) for f g h
    by (simp add: register_pair_apply assoc_apply comp_update_assoc)
qed

lemma pair_o_assoc'[simp]:
  assumes [simp]: compatible F G compatible G H compatible F H
  shows ((F; G); H)  assoc' = (F; (G; H))
proof (rule tensor_extensionality3)
  show register (((F; G); H)  assoc')
    by simp
  show register (F; (G; H))
    by simp
  show (((F; G); H)  assoc') (f u g u h) = (F; (G; H)) (f u g u h) for f g h
    by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
qed

lemma assoc'_o_assoc[simp]: assoc' o assoc = id
  apply (rule tensor_extensionality3')
  by auto

lemma assoc'_assoc[simp]: assoc' (assoc x) = x
  by (simp add: pointfree_idE)

lemma assoc_o_assoc'[simp]: assoc o assoc' = id
  apply (rule tensor_extensionality3)
  by auto

lemma assoc_assoc'[simp]: assoc (assoc' x) = x
  by (simp add: pointfree_idE)

lemma inv_assoc[simp]: inv assoc = assoc'
  using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast

lemma inv_assoc'[simp]: inv assoc' = assoc
  by (simp add: inv_equality)

lemma [simp]: bij assoc
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

lemma [simp]: bij assoc'
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

subsection Iso-registers

definition iso_register F  register F  (G. register G  F o G = id  G o F = id)
  for F :: _::domain update  _::domain update

lemma iso_registerI:
  assumes register F register G F o G = id G o F = id
  shows iso_register F
  using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast

lemma iso_register_inv: iso_register F  iso_register (inv F)
  by (metis inv_unique_comp iso_register_def)

lemma iso_register_inv_comp1: iso_register F  inv F o F = id
  using inv_unique_comp iso_register_def by blast

lemma iso_register_inv_comp2: iso_register F  F o inv F = id
  using inv_unique_comp iso_register_def by blast


lemma iso_register_id[simp]: iso_register id
  by (simp add: iso_register_def)

lemma iso_register_is_register: iso_register F  register F
  using iso_register_def by blast

lemma iso_register_comp[simp]:
  assumes [simp]: iso_register F iso_register G
  shows iso_register (F o G)
proof -
  from assms obtain F' G' where [simp]: register F' register G' F o F' = id F' o F = id
    G o G' = id G' o G = id
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=G' o F'])
       apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
     apply (metis F  F' = id G  G' = id fcomp_assoc fcomp_comp id_fcomp)
    by (metis (no_types, lifting) F  F' = id F'  F = id G'  G = id fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed


lemma iso_register_tensor_is_iso_register[simp]:
  assumes [simp]: iso_register F iso_register G
  shows iso_register (F r G)
proof -
  from assms obtain F' G' where [simp]: register F' register G' F o F' = id F' o F = id
    G o G' = id G' o G = id
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=F' r G'])
    by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed

lemma iso_register_bij: iso_register F  bij F
  using iso_register_def o_bij by auto

lemma inv_register_tensor[simp]: 
  assumes [simp]: iso_register F iso_register G
  shows inv (F r G) = inv F r inv G
  apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij 
              simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                    iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
  by (metis eq_id_iff register_tensor_id)

lemma iso_register_swap[simp]: iso_register swap
  apply (rule iso_registerI[of _ swap])
  by auto

lemma iso_register_assoc[simp]: iso_register assoc
  apply (rule iso_registerI[of _ assoc'])
  by auto

lemma iso_register_assoc'[simp]: iso_register assoc'
  apply (rule iso_registerI[of _ assoc])
  by auto

definition equivalent_registers F G  (register F  (I. iso_register I  F o I = G))
  for F G :: _::domain update  _::domain update

lemma iso_register_equivalent_id[simp]: equivalent_registers id F  iso_register F
  by (simp add: equivalent_registers_def)

lemma equivalent_registersI:
  assumes register F
  assumes iso_register I
  assumes F o I = G
  shows equivalent_registers F G
  using assms unfolding equivalent_registers_def by blast

lemma equivalent_registers_register_left: equivalent_registers F G  register F
  using equivalent_registers_def by auto

lemma equivalent_registers_register_right: register G if equivalent_registers F G
  by (metis equivalent_registers_def iso_register_def register_comp that)

lemma equivalent_registers_sym:
  assumes equivalent_registers F G
  shows equivalent_registers G F
  by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)

lemma equivalent_registers_trans[trans]: 
  assumes equivalent_registers F G and equivalent_registers G H
  shows equivalent_registers F H
proof -
  from assms have [simp]: register F register G
    by (auto simp: equivalent_registers_def)
  from assms(1) obtain I where [simp]: iso_register I and F o I = G
    using equivalent_registers_def by blast
  from assms(2) obtain J where [simp]: iso_register J and G o J = H
    using equivalent_registers_def by blast
  have register F
    by (auto simp: equivalent_registers_def)
  moreover have iso_register (I o J)
    using iso_register I iso_register J iso_register_comp by blast
  moreover have F o (I o J) = H
    by (simp add: F  I = G G  J = H o_assoc)
  ultimately show ?thesis
    by (rule equivalent_registersI)
qed

lemma equivalent_registers_assoc[simp]:
  assumes [simp]: compatible F G compatible F H compatible G H
  shows equivalent_registers (F;(G;H)) ((F;G);H)
  apply (rule equivalent_registersI[where I=assoc])
  by auto

lemma equivalent_registers_pair_right:
  assumes [simp]: compatible F G
  assumes eq: equivalent_registers G H
  shows equivalent_registers (F;G) (F;H)
proof -
  from eq obtain I where [simp]: iso_register I and G o I = H
    by (metis equivalent_registers_def)
  then have *: (F;G)  (id r I) = (F;H)
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=id r I])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_pair_left:
  assumes [simp]: compatible F G
  assumes eq: equivalent_registers F H
  shows equivalent_registers (F;G) (H;G)
proof -
  from eq obtain I where [simp]: iso_register I and F o I = H
    by (metis equivalent_registers_def)
  then have *: (F;G)  (I r id) = (H;G)
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=I r id])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_comp:
  assumes register H
  assumes equivalent_registers F G
  shows equivalent_registers (H o F) (H o G)
  by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)

subsection Compatibility simplification

text The simproc compatibility_warn› produces helpful warnings for subgoals of the form
   termcompatible x y that are probably unsolvable due to missing declarations of 
   variable compatibility facts. Same for subgoals of the form termregister x.
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = 
let val thy_string = Markup.markup (Theory.get_markup theory) (Context.theory_name theory)
in
fn m => fn ctxt => fn ct => let
  val (x,y) = case Thm.term_of ct of
                 Const(const_namecompatible,_ ) $ x $ y => (x, SOME y)
               | Const(const_nameregister,_ ) $ x => (x, NONE)
  val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
  fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
  val _ = case (x,y) of
        (Free(n,T), SOME (Free(n',T'))) => 
            if String.isPrefix ":" n orelse String.isPrefix ":" n' then 
                      w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else if n=n' then (if T=T' then () 
                          else w ("In simplification subgoal " ^ Lazy.force str ^ 
                               ", variables have same name and different types.\n" ^
                               "Probably something is wrong."))
                    else w ("Simplification subgoal " ^ Lazy.force str ^ 
                            " occurred but cannot be solved.\n" ^
                            "Please add assumption/fact  [simp]: ‹" ^ Lazy.force str ^ 
                            "›  somewhere.")
      | (Free(n,T), NONE) => 
            if String.isPrefix ":" n then 
                      w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                    "Please add assumption/fact  [simp]: ‹" ^ Lazy.force str ^ "›  somewhere.")
      | _ => ()
  in NONE end
end


named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule

lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
  asm_rl[of compatible _ _] asm_rl[of iso_register _] asm_rl[of register _] iso_register_inv

text The following declares an attribute [register]›. When the attribute is applied to a fact
  of the form termregister F, termiso_register F, termcompatible F G or a conjunction of these,
  then those facts are added to the simplifier together with some derived theorems
  (e.g., termcompatible F G also adds termregister F).

  In theory Laws_Complement›, support for termis_unit_register F and termcomplements F G is
  added to this attribute.

setup 
let
fun add thm results = 
  Net.insert_term (K true) (Thm.concl_of thm, thm) results
  handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
  NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
  results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
  val ctxt = Context.proof_of context
  val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
  val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
  val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
  (* val _ = print thms *)
  in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup bindingregister
 (Scan.succeed (Thm.declaration_attribute declare))
  "Add register-related rules to the simplifier"
end


subsection Notation

no_notation comp_update (infixl "*u" 55)
no_notation tensor_update (infixr "u" 70)

bundle register_notation begin
notation register_tensor (infixr "r" 70)
notation register_pair ("'(_;_')")
end

bundle no_register_notation begin
no_notation register_tensor (infixr "r" 70)
no_notation register_pair ("'(_;_')")
end

end

Theory Axioms_Complement

section Axioms of complements

theory Axioms_Complement
  imports Laws
begin

typedecl ('a, 'b) complement_domain
instance complement_domain :: (domain, domain) domain..

― ‹We need that there is at least one object in our category. We call is termsome_domain.
typedecl some_domain
instance some_domain :: domain..

axiomatization where 
  complement_exists: register F  G :: ('a, 'b) complement_domain update  'b update. compatible F G  iso_register (F;G) for F :: 'a::domain update  'b::domain update

axiomatization where complement_unique: compatible F G  iso_register (F;G)  compatible F H  iso_register (F;H)
           equivalent_registers G H 
    for F :: 'a::domain update  'b::domain update and G :: 'g::domain update  'b update and H :: 'h::domain update  'b update

end

Theory Laws_Complement

section Generic laws about complements

theory Laws_Complement
  imports Laws Axioms_Complement
begin

notation comp_update (infixl "*u" 55)
notation tensor_update (infixr "u" 70)

definition complements F G  compatible F G  iso_register (F;G)

lemma complementsI: compatible F G  iso_register (F;G)  complements F G
  using complements_def by blast

lemma complements_sym: complements G F if complements F G
proof (rule complementsI)
  show [simp]: compatible G F
    using compatible_sym complements_def that by blast
  from that have iso_register (F;G)
    by (meson complements_def)
  then obtain I where [simp]: register I and (F;G) o I = id and I o (F;G) = id
    using iso_register_def by blast
  have register (swap o I)
    using register I register_comp register_swap by blast
  moreover have (G;F) o (swap o I) = id
    by (simp add: (F;G)  I = id rewriteL_comp_comp)
  moreover have (swap o I) o (G;F) = id
    by (metis (no_types, opaque_lifting) swap_swap I  (F;G) = id calculation(2) comp_def eq_id_iff)
  ultimately show iso_register (G;F)
    using compatible G F iso_register_def pair_is_register by blast
qed

definition complement :: ('a::domain update  'b::domain update)  (('a,'b) complement_domain update  'b update) where
  complement F = (SOME G :: ('a, 'b) complement_domain update  'b update. compatible F G  iso_register (F;G))

lemma register_complement[simp]: register (complement F) if register F
  using complement_exists[OF that]
  by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)

lemma complement_is_complement:
  assumes register F
  shows complements F (complement F)
  using complement_exists[OF assms] unfolding complements_def
  by (metis (mono_tags, lifting) complement_def some_eq_imp)

lemma complement_unique:
  assumes complements F G
  shows equivalent_registers G (complement F)
  apply (rule complement_unique[where F=F])
  using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+

lemma compatible_complement[simp]: register F  compatible F (complement F)
  using complement_is_complement complements_def by blast

lemma complements_register_tensor:
  assumes [simp]: register F register G
  shows complements (F r G) (complement F r complement G)
proof (rule complementsI)
  have sep4: separating TYPE('z::domain) {(a u b) u (c u d) |a b c d. True}
    apply (rule separating_tensor'[where A={(a u b) |a b. True} and B={(c u d) |c d. True}])
      apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
     apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
    by auto
  show compat: compatible (F r G) (complement F r complement G)
    by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
  let ?reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))
  have [simp]: register ?reorder
    by auto
  have [simp]: ?reorder ((a u b) u (c u d)) = ((a u c) u (b u d)) 
    for a::'t::domain update and b::'u::domain update and c::'v::domain update and d::'w::domain update
    by (simp add: register_pair_apply Fst_def Snd_def tensor_update_mult)
  have [simp]: iso_register ?reorder
    apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
     apply (rule register_eqI[OF sep4]) apply auto[3]
    apply (rule register_eqI[OF sep4]) by auto
  have (F r G; complement F r complement G) = ((F; complement F) r (G; complement G)) o ?reorder
    apply (rule register_eqI[OF sep4])
    by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
        simp: compat register_pair_apply tensor_update_mult)
  moreover have iso_register 
    apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
    using assms complement_is_complement complements_def by blast+
  ultimately show iso_register (F r G;complement F r complement G)
    by simp
qed

definition is_unit_register where
  is_unit_register U  complements U id

lemma register_unit_register[simp]: is_unit_register U  register U
  by (simp add: compatible_def complements_def is_unit_register_def)

lemma unit_register_compatible[simp]: compatible U X if is_unit_register U register X
  by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))

lemma unit_register_compatible'[simp]: compatible X U if is_unit_register U register X
  using compatible_sym that(1) that(2) unit_register_compatible by blast

lemma compatible_complement_left[simp]: register X  compatible (complement X) X
  using compatible_sym complement_is_complement complements_def by blast

lemma compatible_complement_right[simp]: register X  compatible X (complement X)
  using complement_is_complement complements_def by blast

lemma unit_register_pair[simp]: equivalent_registers X (U; X) if [simp]: is_unit_register U register X
proof -
  have equivalent_registers id (U; id)
    using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
  also have equivalent_registers  (U; (X; complement X))
    apply (rule equivalent_registers_pair_right)
     apply (auto intro!: unit_register_compatible)
    using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
  also have equivalent_registers  ((U; X); complement X)
    apply (rule equivalent_registers_assoc)
    by auto
  finally have complements (U; X) (complement X)
    by (auto simp: equivalent_registers_def complements_def)
  moreover have equivalent_registers (X; complement X) id
    by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
  ultimately show ?thesis
    by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
qed

lemma unit_register_compose_left:
  assumes [simp]: is_unit_register U
  assumes [simp]: register A
  shows is_unit_register (A o U)
proof -
  have compatible (A o U) (A; complement A)
    apply (auto intro!: compatible3')
    by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
  then have compat[simp]: compatible (A o U) id
    by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
  have equivalent_registers (A o U; id) (A o U; (A; complement A))
    apply (auto intro!: equivalent_registers_pair_right)
    using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
  also have equivalent_registers  ((A o U; A o id); complement A)
    apply auto
    by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
  also have equivalent_registers  (A o (U; id); complement A)
    by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
  also have equivalent_registers  (A o id; complement A)
    apply (intro equivalent_registers_pair_left equivalent_registers_comp)
      apply (auto simp: assms)
    using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
  also have equivalent_registers  id
    by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
  finally show ?thesis
    using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
qed

lemma unit_register_compose_right:
  assumes [simp]: is_unit_register U
  assumes [simp]: iso_register A
  shows is_unit_register (U o A)
proof (unfold is_unit_register_def, rule complementsI)
  show compatible (U  A) id
    by (simp add: iso_register_is_register)
  have 1: iso_register ((U;id)  A r id)
    by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
  have 2: id  ((U;id)  A r id) = (U  A;id)
    by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
  show iso_register (U  A;id)
    using 1 2 by auto
qed

lemma unit_register_unique:
  assumes is_unit_register F
  assumes is_unit_register G
  shows equivalent_registers F G
proof -
  have complements F id complements G id
    using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
  then show ?thesis
    by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
qed

lemma unit_register_domains_isomorphic:
  fixes F :: 'a::domain update  'c::domain update
  fixes G :: 'b::domain update  'd::domain update
  assumes is_unit_register F
  assumes is_unit_register G
  shows I :: 'a update  'b update. iso_register I
proof -
  have is_unit_register ((λd. tensor_update id_update d) o G)
    by (simp add: assms(2) unit_register_compose_left)
  moreover have is_unit_register ((λc. tensor_update c id_update) o F)
    using assms(1) register_tensor_left unit_register_compose_left by blast
  ultimately have equivalent_registers ((λd. tensor_update id_update d) o G) ((λc. tensor_update c id_update) o F)
    using unit_register_unique by blast
  then show ?thesis
    unfolding equivalent_registers_def by auto
qed


lemma id_complement_is_unit_register[simp]: is_unit_register (complement id)
  by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)

type_synonym unit_register_domain = (some_domain, some_domain) complement_domain
definition unit_register :: unit_register_domain update  'a::domain update where unit_register = (SOME U. is_unit_register U)

lemma unit_register_is_unit_register[simp]: is_unit_register (unit_register :: unit_register_domain update  'a::domain update)
proof -
  let ?U0 = complement id :: unit_register_domain update  some_domain update
  let ?U1 = complement id :: ('a, 'a) complement_domain update  'a update
  have is_unit_register ?U0 is_unit_register ?U1
    by auto
  then obtain I :: unit_register_domain update  ('a, 'a) complement_domain update where iso_register I
    apply atomize_elim by (rule unit_register_domains_isomorphic)
  with is_unit_register ?U1 have is_unit_register (?U1 o I)
    by (rule unit_register_compose_right)
  then show ?thesis
    by (metis someI_ex unit_register_def)
qed

lemma unit_register_domain_tensor_unit:
  fixes U :: 'a::domain update  _
  assumes is_unit_register U
  shows I :: 'b::domain update  ('a*'b) update. iso_register I
  (* Can we show that I = (λx. tensor_update id_update x) ? It would be nice but I do not see how to prove it. *)
proof -
  have equivalent_registers (id :: 'b update  _) (complement id; id)
    using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
  then obtain J :: 'b update  ((('b, 'b) complement_domain * 'b) update) where iso_register J
    using equivalent_registers_def iso_register_inv by blast
  moreover obtain K :: ('b, 'b) complement_domain update  'a update where iso_register K
    using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
  ultimately have iso_register ((K r id) o J)
    by auto
  then show ?thesis   
    by auto
qed

lemma compatible_complement_pair1:
  assumes compatible F G
  shows compatible F (complement (F;G))
  by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)

lemma compatible_complement_pair2:
  assumes [simp]: compatible F G
  shows compatible G (complement (F;G))
proof -
  have compatible (F;G) (complement (F;G))
    by simp
  then have compatible ((F;G) o Snd) (complement (F;G))
    by auto
  then show ?thesis
    by (auto simp: register_pair_Snd)
qed

lemma equivalent_complements:
  assumes complements F G
  assumes equivalent_registers G G'
  shows complements F G'
  apply (rule complementsI)
   apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
  by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)

lemma complements_complement_pair:
  assumes [simp]: compatible F G
  shows complements F (G; complement (F;G))
proof (rule complementsI)
  have equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))
    apply (rule equivalent_registers_assoc)
    by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
  also have equivalent_registers  id
    by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
  finally show iso_register (F;(G;complement (F;G)))
    using equivalent_registers_sym iso_register_equivalent_id by blast
  show compatible F (G;complement (F;G))
    using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
qed

lemma equivalent_registers_complement:
  assumes equivalent_registers F G
  shows equivalent_registers (complement F) (complement G)
proof -
  have complements F (complement F)
    using assms complement_is_complement equivalent_registers_register_left by blast
  with assms have complements G (complement F)
    by (meson complements_sym equivalent_complements)
  then show ?thesis
    by (rule complement_unique)
qed


lemma complements_complement_pair':
  assumes [simp]: compatible F G
  shows complements G (F; complement (F;G))
proof -
  have equivalent_registers (F;G) (G;F)
    apply (rule equivalent_registersI[where I=swap])
    by auto
  then have equivalent_registers (complement (F;G)) (complement (G;F))
    by (rule equivalent_registers_complement)
  then have equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))
    apply (rule equivalent_registers_pair_right[rotated])
    using assms compatible_complement_pair1 by blast
  moreover have complements G (F; complement (G;F))
    apply (rule complements_complement_pair)
    using assms compatible_sym by blast
  ultimately show ?thesis
    by (meson equivalent_complements equivalent_registers_sym)
qed

lemma complements_chain: 
  assumes [simp]: register F register G
  shows complements (F o G) (complement F; F o complement G)
proof (rule complementsI)
  show compatible (F o G) (complement F; F o complement G)
    by auto
  have equivalent_registers (F  G;(complement F;F  complement G)) (F  G;(F  complement G;complement F))
    apply (rule equivalent_registersI[where I=id r swap])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have equivalent_registers  ((F  G;F  complement G);complement F)
    apply (rule equivalent_registersI[where I=assoc])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have equivalent_registers  (F o (G; complement G);complement F)
    by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
        equivalent_registers_sym equivalent_registers_trans register_comp_pair)
  also have equivalent_registers  (F o id;complement F)
    apply (rule equivalent_registers_pair_left, simp)
    apply (rule equivalent_registers_comp, simp)
    by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
  also have equivalent_registers  id
    by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
  finally show iso_register (F  G;(complement F;F  complement G))
    using equivalent_registers_sym iso_register_equivalent_id by blast
qed

lemma complements_Fst_Snd[simp]: complements Fst Snd
  by (auto intro!: complementsI simp: pair_Fst_Snd)

lemma complements_Snd_Fst[simp]: complements Snd Fst
  by (auto intro!: complementsI simp flip: swap_def)

lemma compatible_unit_register[simp]: register F  compatible F unit_register
  using compatible_sym unit_register_compatible unit_register_is_unit_register by blast

lemma complements_id_unit_register[simp]: complements id unit_register
  using complements_sym is_unit_register_def unit_register_is_unit_register by blast

lemma complements_iso_unit_register: iso_register I  is_unit_register U  complements I U
  using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast

lemma iso_register_complement_is_unit_register[simp]:
  assumes iso_register F
  shows is_unit_register (complement F)
  by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)

text Adding support for termis_unit_register F and termcomplements F G to the [@{attribute register}] attribute
lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
lemmas [register_attribute_rule_immediate] = asm_rl[of is_unit_register _]

no_notation comp_update (infixl "*u" 55)
no_notation tensor_update (infixr "u" 70)

end

Theory Axioms_Classical

section Classical instantiation of registerss

(* AXIOM INSTANTIATION (use instantiate_laws.py to generate Laws_Classical.thy)
 
   domain → type
   comp_update → map_comp
   id_update → Some

   Generic laws about registers → Generic laws about registers, instantiated classically
*)

theory Axioms_Classical
  imports Main
begin

type_synonym 'a update = 'a  'a

lemma id_update_left: "Some m a = a"
  by (auto intro!: ext simp add: map_comp_def option.case_eq_if)
lemma id_update_right: "a m Some = a"
  by auto

lemma comp_update_assoc: "(a m b) m c = a m (b m c)"
  by (auto intro!: ext simp add: map_comp_def option.case_eq_if)

type_synonym ('a,'b) preregister = 'a update  'b update
definition preregister :: ('a,'b) preregister  bool where
  preregister F  (g s. a m. F a m = (case a (g m) of None  None | Some x  s x m))

lemma id_preregister: preregister id
  unfolding preregister_def
  apply (rule exI[of _ λm. m])
  apply (rule exI[of _ λa m. Some a])
  by (simp add: option.case_eq_if)

lemma preregister_mult_right: preregister (λa. a m z)
  unfolding preregister_def 
  apply (rule exI[of _ λm. the (z m)])
  apply (rule exI[of _ λx m. case z m of None  None | _  Some x])
  by (auto simp add: option.case_eq_if)

lemma preregister_mult_left: preregister (λa. z m a)
  unfolding preregister_def 
  apply (rule exI[of _ λm. m])
  apply (rule exI[of _ λx m. z x])
  by (auto simp add: option.case_eq_if)

lemma comp_preregister: "preregister (G  F)" if "preregister F" and preregister G
proof -
  from preregister F
  obtain sF gF where F: F a m = (case a (gF m) of None  None | Some x  sF x m) for a m
    using preregister_def by blast
  from preregister G
  obtain sG gG where G: G a m = (case a (gG m) of None  None | Some x  sG x m) for a m
    using preregister_def by blast
  define s g where s a m = (case sF a (gG m) of None  None | Some x  sG x m)
    and g m = gF (gG m) for a m
  have (G  F) a m = (case a (g m) of None  None | Some x  s x m) for a m
    unfolding F G s_def g_def
    by (auto simp add: option.case_eq_if)
  then show "preregister (G  F)"
    using preregister_def by blast
qed

definition tensor_update :: 'a update  'b update  ('a×'b) update where
  tensor_update a b m = (case a (fst m) of None  None | Some x  (case b (snd m) of None  None | Some y  Some (x,y)))

lemma tensor_update_mult: tensor_update a c m tensor_update b d = tensor_update (a m b) (c m d)
  by (auto intro!: ext simp add: map_comp_def option.case_eq_if tensor_update_def)

definition update1 :: 'a  'a  'a update where
  update1 x y m = (if m=x then Some y else None)

lemma update1_extensionality:
  assumes preregister F
  assumes preregister G
  assumes FGeq: x y. F (update1 x y) = G (update1 x y)
  shows "F = G"
proof (rule ccontr)
  assume neq: F  G
  then obtain z m where neq': F z m  G z m 
    apply atomize_elim by auto
  obtain gF sF where gsF: F z m = (case z (gF m) of None  None | Some x  sF x m) for z m
    using preregister F preregister_def by blast
  obtain gG sG where gsG: G z m = (case z (gG m) of None  None | Some x  sG x m) for z m
    using preregister G preregister_def by blast
  consider (abeq) x where z (gF m) = Some x z (gG m) = Some x gF m = gG m
    | (abnone) z (gG m) = None z (gF m) = None
    | (neqF) x where gF m  gG m F z m = Some x
    | (neqG) y where gF m  gG m G z m = Some y
    | (neqNone) gF m  gG m F z m = None G z m = None
    apply atomize_elim by (metis option.exhaust_sel)
  then show False
  proof cases
    case (abeq x)
    then have F z m = sF x m and G z m = sG x m
      by (simp_all add: gsF gsG)
    moreover have F (update1 (gF m) x) m = sF x m
      by (simp add: gsF update1_def)
    moreover have G (update1 (gF m) x) m = sG x m
      by (simp add: abeq gsG update1_def)
    ultimately show False
      using FGeq neq' by force
  next
    case abnone
    then show False
      using gsF gsG neq' by force
  next
    case neqF
    moreover
    have F (update1 (gF m) (the (z (gF m)))) m = F z m
      by (metis gsF neqF(2) option.case_eq_if option.simps(3) option.simps(5) update1_def)
    moreover have G (update1 (gF m) (the (z (gF m)))) m = None
      by (metis gsG neqF(1) option.case_eq_if update1_def)
    ultimately show False
      using FGeq by force
  next
    case neqG
    moreover
    have G (update1 (gG m) (the (z (gG m)))) m = G z m
      by (metis gsG neqG(2) option.case_eq_if option.distinct(1) option.simps(5) update1_def)
    moreover have F (update1 (gG m) (the (z (gG m)))) m = None
      by (simp add: gsF neqG(1) update1_def)
    ultimately show False
      using FGeq by force
  next
    case neqNone
    with neq' show False
      by fastforce
  qed
qed

lemma tensor_extensionality:
  assumes preregister F
  assumes preregister G
  assumes FGeq: a b. F (tensor_update a b) = G (tensor_update a b)
  shows "F = G"
proof -
  have F (update1 x y) = G (update1 x y) for x y
    using FGeq[of update1 (fst x) (fst y) update1 (snd x) (snd y)]
    apply (auto intro!:ext simp: tensor_update_def[abs_def] update1_def[abs_def])
    by (smt (z3) assms(1) assms(2) option.case(2) option.case_eq_if preregister_def prod.collapse)
  with assms(1,2) show "F = G"
    by (rule update1_extensionality)
qed

definition "valid_getter_setter g s  
  (b. b = s (g b) b)  (a b. g (s a b) = a)  (a a' b. s a (s a' b) = s a b)"

definition register_from_getter_setter g s a m = (case a (g m) of None  None | Some x  Some (s x m))
definition register_apply F a = the o F (Some o a)
definition setter F a m = register_apply F (λ_. a) m for F :: 'a update  'b update
definition getter F m = (THE x. setter F x m = m) for F :: 'a update  'b update

lemma
  assumes valid_getter_setter g s
  shows getter_of_register_from_getter_setter[simp]: getter (register_from_getter_setter g s) = g
    and setter_of_register_from_getter_setter[simp]: setter (register_from_getter_setter g s) = s
proof -
  define g' s' where g' = getter (register_from_getter_setter g s)
    and s' = setter (register_from_getter_setter g s)
  show s' = s
    by (auto intro!:ext simp: s'_def setter_def register_apply_def register_from_getter_setter_def)
  moreover show g' = g
  proof (rule ext, rename_tac m)
    fix m
    have g' m = (THE x. s x m = m)
      by (auto intro!:ext simp: g'_def s'_def[symmetric] s'=s getter_def register_apply_def register_from_getter_setter_def)
    moreover have s (g m) m = m
      by (metis assms valid_getter_setter_def)
    moreover have x = x' if s x m = m s x' m = m for x x'
      by (metis assms that(1) that(2) valid_getter_setter_def)
    ultimately show g' m = g m
      by (simp add: Uniq_def the1_equality')
  qed
qed

definition register :: ('a,'b) preregister  bool where
  register F  (g s. F = register_from_getter_setter g s  valid_getter_setter g s)

lemma register_of_id: register F  F Some = Some
  by (auto simp add: register_def valid_getter_setter_def register_from_getter_setter_def)

lemma register_id: register id
  unfolding register_def
  apply (rule exI[of _ id], rule exI[of _ λa m. a])
  by (auto intro!: ext simp: option.case_eq_if register_from_getter_setter_def valid_getter_setter_def)

lemma register_tensor_left: register (λa. tensor_update a Some)
  apply (auto simp: register_def)
  apply (rule exI[of _ fst])
  apply (rule exI[of _ λx' (x,y). (x',y)])
  by (auto intro!: ext simp add: tensor_update_def valid_getter_setter_def register_from_getter_setter_def option.case_eq_if)

lemma register_tensor_right: register (λa. tensor_update Some a)
  apply (auto simp: register_def)
  apply (rule exI[of _ snd])
  apply (rule exI[of _ λy' (x,y). (x,y')])
  by (auto intro!: ext simp add: tensor_update_def valid_getter_setter_def register_from_getter_setter_def option.case_eq_if)

lemma register_preregister: "preregister F" if register F
proof -
  from register F
  obtain s g where F: F a m = (case a (g m) of None  None | Some x  Some (s x m)) for a m
    unfolding register_from_getter_setter_def register_def by blast
  show ?thesis
    unfolding preregister_def
    apply (rule exI[of _ g])
    apply (rule exI[of _ λx m. Some (s x m)])
    using F by simp
qed

lemma register_comp: "register (G  F)" if register F and register G
  for F :: "('a,'b) preregister" and G :: "('b,'c) preregister"
proof -
  from register F
  obtain sF gF where F: F a m = (case a (gF m) of None  None | Some x  Some (sF x m))
    and validF: valid_getter_setter gF sF for a m
    unfolding register_def register_from_getter_setter_def by blast
  from register G
  obtain sG gG where G: G a m = (case a (gG m) of None  None | Some x  Some (sG x m))
    and validG: valid_getter_setter gG sG for a m
    unfolding register_def register_from_getter_setter_def by blast
  define s g where s a m = sG (sF a (gG m)) m and g m = gF (gG m) for a m
  have (G  F) a m = (case a (g m) of None  None | Some x  Some (s x m)) for a m
    by (auto simp add: option.case_eq_if F G s_def g_def)
  moreover have valid_getter_setter g s
    using validF validG by (auto simp: valid_getter_setter_def s_def g_def)
  ultimately show "register (G  F)"
    unfolding register_def register_from_getter_setter_def by blast
qed

lemma register_mult: "register F  F a m F b = F (a m b)"
  by (auto intro!: ext simp: register_def register_from_getter_setter_def[abs_def] valid_getter_setter_def map_comp_def option.case_eq_if)

definition register_pair ::
  ('a update  'c update)  ('b update  'c update)  (('a×'b) update  'c update) where
  register_pair F G =
    register_from_getter_setter (λm. (getter F m, getter G m)) (λ(a,b) m. setter F a (setter G b m))

lemma compatible_setter:
  assumes [simp]: register F register G
  assumes compat: a b. F a m G b = G b m F a
  shows setter F x o setter G y = setter G y o setter F x
  using compat apply (auto intro!: ext simp: setter_def register_apply_def o_def map_comp_def)
  by (smt (verit, best) assms(1) assms(2) option.case_eq_if option.distinct(1) register_def register_from_getter_setter_def)

lemma register_pair_apply:
  assumes [simp]: register F register G
  assumes a b. F a m G b = G b m F a
  shows (register_pair F G) (tensor_update a b) = F a m G b
proof -
  have validF: valid_getter_setter (getter F) (setter F) and validG: valid_getter_setter (getter G) (setter G)
    by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
  then have F: F = register_from_getter_setter (getter F) (setter F) and G: G = register_from_getter_setter (getter G) (setter G)
    by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
  have gFsG: getter F (setter G y m) = getter F m for y m
  proof -
    have getter F (setter G y m) = getter F (setter G y (setter F (getter F m) m))
      using validF by (metis valid_getter_setter_def)
    also have  = getter F (setter F (getter F m) (setter G y m))
      by (metis (mono_tags, lifting) assms(1) assms(2) assms(3) comp_eq_dest_lhs compatible_setter)
    also have  = getter F m
      by (metis validF valid_getter_setter_def)
    finally show ?thesis by -
  qed

  show ?thesis
    apply (subst (2) F, subst (2) G)
    by (auto intro!:ext simp: register_pair_def tensor_update_def map_comp_def option.case_eq_if
              register_from_getter_setter_def gFsG)
qed

lemma register_pair_is_register:
  fixes F :: 'a update  'c update and G
  assumes [simp]: register F and [simp]: register G
  assumes compat: a b. F a m G b = G b m F a
  shows register (register_pair F G)
proof -
  have validF: valid_getter_setter (getter F) (setter F) and validG: valid_getter_setter (getter G) (setter G)
    by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
  then have valid_getter_setter (λm. (getter F m, getter G m)) (λ(a, b) m. setter F a (setter G b m))
    apply (simp add: valid_getter_setter_def)
    by (metis (mono_tags, lifting) assms comp_eq_dest_lhs compat compatible_setter)
  then show ?thesis
    by (auto simp: register_pair_def register_def)
qed

end

Theory Laws_Classical

(*
 * This is an autogenerated file. Do not edit.
 * The original is Laws.thy. It was converted using instantiate_laws.py.
 *)

section Generic laws about registers, instantiated classically

theory Laws_Classical
  imports Axioms_Classical
begin

text This notation is only used inside this file
notation map_comp (infixl "*u" 55)
notation tensor_update (infixr "u" 70)
notation register_pair ("'(_;_')")

subsection Elementary facts

declare id_preregister[simp]
declare id_update_left[simp]
declare id_update_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]

subsection Preregisters

lemma preregister_tensor_left[simp]: preregister (λb::'b::type update. tensor_update a b)
  for a :: 'a::type update
proof -
  have preregister ((λb1::('a×'b) update. (a u Some) *u b1) o (λb. tensor_update Some b))
    by (rule comp_preregister; simp)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

lemma preregister_tensor_right[simp]: preregister (λa::'a::type update. tensor_update a b)  
  for b :: 'b::type update
proof -
  have preregister ((λa1::('a×'b) update. (Some u b) *u a1) o (λa. tensor_update a Some))
    by (rule comp_preregister, simp_all)
  then show ?thesis
    by (simp add: o_def tensor_update_mult)
qed

subsection Registers

lemma id_update_tensor_register[simp]:
  assumes register F
  shows register (λa::'a::type update. Some u F a)
  using assms apply (rule register_comp[unfolded o_def])
  by simp

lemma register_tensor_id_update[simp]:
  assumes register F
  shows register (λa::'a::type update. F a u Some)
  using assms apply (rule register_comp[unfolded o_def])
  by simp

subsection Tensor product of registers

definition register_tensor  (infixr "r" 70) where
  "register_tensor F G = register_pair (λa. tensor_update (F a) Some) (λb. tensor_update Some (G b))"

lemma register_tensor_is_register: 
  fixes F :: "'a::type update  'b::type update" and G :: "'c::type update  'd::type update"
  shows "register F  register G  register (F r G)"
  unfolding register_tensor_def
  apply (rule register_pair_is_register)
  by (simp_all add: tensor_update_mult)

lemma register_tensor_apply[simp]:
  fixes F :: "'a::type update  'b::type update" and G :: "'c::type update  'd::type update"
  assumes register F and register G
  shows "(F r G) (a u b) = F a u G b"
  unfolding register_tensor_def
  apply (subst register_pair_apply)
  unfolding register_tensor_def 
  by (simp_all add: assms tensor_update_mult)

definition "separating (_::'b::type itself) A  
  (F G :: 'a::type update  'b update. preregister F  preregister G  (xA. F x = G x)  F = G)"

lemma separating_UNIV[simp]: separating TYPE(_) UNIV
  unfolding separating_def by auto

lemma separating_mono: A  B  separating TYPE('a::type) A  separating TYPE('a) B
  unfolding separating_def by (meson in_mono) 

lemma register_eqI: separating TYPE('b::type) A  preregister F  preregister G  (x. xA  F x = G x)  F = (G::_  'b update)
  unfolding separating_def by auto

lemma separating_tensor:
  fixes A :: 'a::type update set and B :: 'b::type update set
  assumes [simp]: separating TYPE('c::type) A
  assumes [simp]: separating TYPE('c) B
  shows separating TYPE('c) {a u b | a b. aA  bB}
proof (unfold separating_def, intro allI impI)
  fix F G :: ('a×'b) update  'c update
  assume [simp]: preregister F preregister G
  have [simp]: preregister (λx. F (a u x)) for a
    using _ preregister F apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: preregister (λx. G (a u x)) for a
    using _ preregister G apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: preregister (λx. F (x u b)) for b
    using _ preregister F apply (rule comp_preregister[unfolded o_def])
    by simp
  have [simp]: preregister (λx. G (x u b)) for b
    using _ preregister G apply (rule comp_preregister[unfolded o_def])
    by simp

  assume x{a u b |a b. aA  bB}. F x = G x
  then have EQ: F (a u b) = G (a u b) if a  A and b  B for a b
    using that by auto
  then have F (a u b) = G (a u b) if a  A for a b
    apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
    using that by auto
  then have F (a u b) = G (a u b) for a b
    apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
    by auto
  then show "F = G"
    apply (rule tensor_extensionality[rotated -1])
    by auto
qed

lemma register_tensor_distrib:
  assumes [simp]: register F register G register H register L
  shows (F r G) o (H r L) = (F o H) r (G o L)
  apply (rule tensor_extensionality)
  by (auto intro!: register_comp register_preregister register_tensor_is_register)

text The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}
lemma separating_tensor':
  fixes A :: 'a::type update set and B :: 'b::type update set
  assumes separating TYPE('c::type) A
  assumes separating TYPE('c) B
  assumes C = {a u b | a b. aA  bB}
  shows separating TYPE('c) C
  using assms
  by (simp add: separating_tensor)

lemma tensor_extensionality3: 
  fixes F G :: ('a::type×'b::type×'c::type) update  'd::type update
  assumes [simp]: register F register G
  assumes "f g h. F (f u g u h) = G (f u g u h)"
  shows "F = G"
proof (rule register_eqI[where A={aubuc| a b c. True}])
  have separating TYPE('d) {b u c |b c. True}
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show separating TYPE('d) {a u b u c |a b c. True}
    apply (rule_tac separating_tensor'[where A=UNIV and B={buc| b c. True}])
    by auto
  show preregister F preregister G by auto
  show x  {a u b u c |a b c. True}  F x = G x for x
    using assms(3) by auto
qed

lemma tensor_extensionality3': 
  fixes F G :: (('a::type×'b::type)×'c::type) update  'd::type update
  assumes [simp]: register F register G
  assumes "f g h. F ((f u g) u h) = G ((f u g) u h)"
  shows "F = G"
proof (rule register_eqI[where A={(aub)uc| a b c. True}])
  have separating TYPE('d) {a u b | a b. True}
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show separating TYPE('d) {(a u b) u c |a b c. True}
    apply (rule_tac separating_tensor'[where B=UNIV and A={aub| a b. True}])
    by auto
  show preregister F preregister G by auto
  show x  {(a u b) u c |a b c. True}  F x = G x for x
    using assms(3) by auto
qed

lemma register_tensor_id[simp]: id r id = id
  apply (rule tensor_extensionality)
  by (auto simp add: register_tensor_is_register)

subsection Pairs and compatibility

definition compatible :: ('a::type update  'c::type update)
                        ('b::type update  'c update)  bool where
  compatible F G  register F  register G  (a b. F a *u G b = G b *u F a)

lemma compatibleI:
  assumes "register F" and "register G"
  assumes a b. (F a) *u (G b) = (G b) *u (F a)
  shows "compatible F G"
  using assms unfolding compatible_def by simp

lemma swap_registers:
  assumes "compatible R S"
  shows "R a *u S b = S b *u R a"
  using assms unfolding compatible_def by metis

lemma compatible_sym: "compatible x y  compatible y x"
  by (simp add: compatible_def)

lemma pair_is_register[simp]:
  assumes "compatible F G"
  shows "register (F; G)"
  by (metis assms compatible_def register_pair_is_register)

lemma register_pair_apply:
  assumes compatible F G
  shows (F; G) (a u b) = (F a) *u (G b)
  apply (rule register_pair_apply)
  using assms unfolding compatible_def by metis+

lemma register_pair_apply':
  assumes compatible F G
  shows (F; G) (a u b) = (G b) *u (F a)
  apply (subst register_pair_apply)
  using assms by (auto simp: compatible_def intro: register_preregister)



lemma compatible_comp_left[simp]: "compatible F G  register H  compatible (F  H) G"
  by (simp add: compatible_def)

lemma compatible_comp_right[simp]: "compatible F G  register H  compatible F (G  H)"
  by (simp add: compatible_def)

lemma compatible_comp_inner[simp]: 
  "compatible F G  register H  compatible (H  F) (H  G)"
  by (smt (verit, best) comp_apply compatible_def register_comp register_mult)

lemma compatible_register1: compatible F G  register F
  by (simp add: compatible_def)
lemma compatible_register2: compatible F G  register G
  by (simp add: compatible_def)

lemma pair_o_tensor:
  assumes "compatible A B" and [simp]: register C and [simp]: register D
  shows "(A; B) o (C r D) = (A o C; B o D)"
  apply (rule tensor_extensionality)
  using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)

lemma compatible_tensor_id_update_left[simp]:
  fixes F :: "'a::type update  'c::type update" and G :: "'b::type update  'c::type update"
  assumes "compatible F G"
  shows "compatible (λa. Some u F a) (λa. Some u G a)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_right[simp]:
  fixes F :: "'a::type update  'c::type update" and G :: "'b::type update  'c::type update"
  assumes "compatible F G"
  shows "compatible (λa. F a u Some) (λa. G a u Some)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_rl[simp]:
  assumes "register F" and "register G"
  shows "compatible (λa. F a u Some) (λa. Some u G a)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma compatible_tensor_id_update_lr[simp]:
  assumes "register F" and "register G"
  shows "compatible (λa. Some u F a) (λa. G a u Some)"
  apply (rule compatibleI)
  using assms by (auto simp: tensor_update_mult)

lemma register_comp_pair:
  assumes [simp]: register F and [simp]: compatible G H
  shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
  show preregister (F  G;F  H) and preregister (F  (G;H))
    by simp_all

  have [simp]: compatible (F o G) (F o H)
    apply (rule compatible_comp_inner, simp)
    by simp
  then have [simp]: register (F  G) register (F  H)
    unfolding compatible_def by auto
  from assms have [simp]: register G register H
    unfolding compatible_def by auto
  fix a b
  show (F  G;F  H) (a u b) = (F  (G;H)) (a u b)
    by (auto simp: register_pair_apply register_mult tensor_update_mult)
qed

lemma swap_registers_left:
  assumes "compatible R S"
  shows "R a *u S b *u c = S b *u R a *u c"
  using assms unfolding compatible_def by metis

lemma swap_registers_right:
  assumes "compatible R S"
  shows "c *u R a *u S b = c *u S b *u R a"
  by (metis assms comp_update_assoc compatible_def)

lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right

subsection Fst and Snd

definition Fst where Fst a = a u Some
definition Snd where Snd a = Some u a

lemma register_Fst[simp]: register Fst
  unfolding Fst_def by (rule register_tensor_left)

lemma register_Snd[simp]: register Snd
  unfolding Snd_def by (rule register_tensor_right)

lemma compatible_Fst_Snd[simp]: compatible Fst Snd
  apply (rule compatibleI, simp, simp)
  by (simp add: Fst_def Snd_def tensor_update_mult)

lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]

definition swap = (Snd; Fst)

lemma swap_apply[simp]: "swap (a u b) = (b u a)"
  unfolding swap_def
  by (simp add: Axioms_Classical.register_pair_apply Fst_def Snd_def tensor_update_mult) 

lemma swap_o_Fst: "swap o Fst = Snd"
  by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
  by (auto simp add: Fst_def Snd_def)

lemma register_swap[simp]: register swap
  by (simp add: swap_def)

lemma pair_Fst_Snd: (Fst; Snd) = id
  apply (rule tensor_extensionality)
  by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma swap_o_swap[simp]: swap o swap = id
  by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)

lemma swap_swap[simp]: swap (swap x) = x
  by (simp add: pointfree_idE)

lemma inv_swap[simp]: inv swap = swap
  by (meson inv_unique_comp swap_o_swap)

lemma register_pair_Fst:
  assumes compatible F G
  shows (F;G) o Fst = F
  using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)

lemma register_pair_Snd:
  assumes compatible F G
  shows (F;G) o Snd = G
  using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)

lemma register_Fst_register_Snd[simp]:
  assumes register F
  shows (F o Fst; F o Snd) = F
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)

lemma register_Snd_register_Fst[simp]: 
  assumes register F
  shows (F o Snd; F o Fst) = F o swap
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)


lemma compatible3[simp]:
  assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible (F; G) H"
proof (rule compatibleI)
  have [simp]: register F register G register H
    using assms compatible_def by auto
  then have [simp]: preregister F preregister G preregister H
    using register_preregister by blast+
  have [simp]: preregister (λa. (F;G) a *u z) for z
    apply (rule comp_preregister[unfolded o_def, of (F;G)])
    by simp_all
  have [simp]: preregister (λa. z *u (F;G) a) for z
    apply (rule comp_preregister[unfolded o_def, of (F;G)])
    by simp_all
  have "(F; G) (f u g) *u H h = H h *u (F; G) (f u g)" for f g h
  proof -
    have FH: "F f *u H h = H h *u F f"
      using assms compatible_def by metis
    have GH: "G g *u H h = H h *u G g"
      using assms compatible_def by metis
    have (F; G) (f u g) *u (H h) = F f *u G g *u H h
      using compatible F G by (subst register_pair_apply, auto)
    also have  = H h *u F f *u G g
      using FH GH by (metis comp_update_assoc)
    also have  = H h *u (F; G) (f u g)
      using compatible F G by (subst register_pair_apply, auto simp: comp_update_assoc)
    finally show ?thesis
      by -
  qed
  then show "(F; G) fg *u (H h) = (H h) *u (F; G) fg" for fg h
    apply (rule_tac tensor_extensionality[THEN fun_cong])
    by auto
  show "register H" and  "register (F; G)"
    by simp_all
qed

lemma compatible3'[simp]:
  assumes "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible F (G; H)"
  apply (rule compatible_sym)
  apply (rule compatible3)
  using assms by (auto simp: compatible_sym)

lemma pair_o_swap[simp]:
  assumes [simp]: "compatible A B"
  shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
  have [simp]: "preregister A" "preregister B"
     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
    by (metis (full_types) assms compatible_register2 register_preregister)
  then show preregister ((A; B)  swap)
    by simp
  show preregister (B; A)
    by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
  show ((A; B)  swap) (a u b) = (B; A) (a u b) for a b
    (* Without the "only:", we would not need the "apply subst",
       but that proof fails when instantiated in Classical.thy *)
    apply (simp only: o_def swap_apply)
    apply (subst register_pair_apply, simp)
    apply (subst register_pair_apply, simp add: compatible_sym)
    by (metis (no_types, lifting) assms compatible_def)
qed


subsection Compatibility of register tensor products

lemma compatible_register_tensor:
  fixes F :: 'a::type update  'e::type update and G :: 'b::type update  'f::type update
    and F' :: 'c::type update  'e update and G' :: 'd::type update  'f update
  assumes [simp]: compatible F F'
  assumes [simp]: compatible G G'
  shows compatible (F r G) (F' r G')
proof -
  note [intro!] = 
    comp_preregister[OF _ preregister_mult_right, unfolded o_def]
    comp_preregister[OF _ preregister_mult_left, unfolded o_def]
    comp_preregister
    register_tensor_is_register
  have [simp]: register F register G register F' register G'
    using assms compatible_def by blast+
  have [simp]: register (F r G) register (F' r G')
    by (auto simp add: register_tensor_def)
  have [simp]: register (F;F') register (G;G')
    by auto
  define reorder :: (('a×'b) × ('c×'d)) update  (('a×'c) × ('b×'d)) update
    where reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))
  have [simp]: preregister reorder
    by (auto simp: reorder_def)
  have [simp]: reorder ((a u b) u (c u d)) = ((a u c) u (b u d)) for a b c d
    apply (simp add: reorder_def register_pair_apply)
    by (simp add: Fst_def Snd_def tensor_update_mult)
  define Φ where Φ c d = ((F;F') r (G;G')) o reorder o (λσ. σ u (c u d)) for c d
  have [simp]: preregister (Φ c d) for c d
    unfolding Φ_def 
    by (auto intro: register_preregister)
  have Φ c d (a u b) = (F r G) (a u b) *u (F' r G') (c u d) for a b c d
    unfolding Φ_def by (auto simp: register_pair_apply tensor_update_mult)
  then have Φ1: Φ c d σ = (F r G) σ *u (F' r G') (c u d) for c d σ
    apply (rule_tac fun_cong[of _ _ σ])
    apply (rule tensor_extensionality)
    by auto
  have Φ c d (a u b) = (F' r G') (c u d) *u (F r G) (a u b) for a b c d
    unfolding Φ_def apply (auto simp: register_pair_apply)
    by (metis assms(1) assms(2) compatible_def tensor_update_mult)
  then have Φ2: Φ c d σ = (F' r G') (c u d) *u (F r G) σ for c d σ
    apply (rule_tac fun_cong[of _ _ σ])
    apply (rule tensor_extensionality)
    by auto
  from Φ1 Φ2 have (F r G) σ *u (F' r G') τ = (F' r G') τ *u (F r G) σ for τ σ
    apply (rule_tac fun_cong[of _ _ τ])
    apply (rule tensor_extensionality)
    by auto
  then show ?thesis
    apply (rule compatibleI[rotated -1])
    by auto
qed

subsection Associativity of the tensor product

definition assoc :: (('a::type×'b::type)×'c::type) update  ('a×('b×'c)) update where 
  assoc = ((Fst; Snd o Fst); Snd o Snd)

lemma assoc_is_hom[simp]: preregister assoc
  by (auto simp: assoc_def)

lemma assoc_apply[simp]: assoc ((a u b) u c) = (a u (b u c))
  by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)

definition assoc' :: ('a×('b×'c)) update  (('a::type×'b::type)×'c::type) update where 
  assoc' = (Fst o Fst; (Fst o Snd; Snd))

lemma assoc'_is_hom[simp]: preregister assoc'
  by (auto simp: assoc'_def)

lemma assoc'_apply[simp]: assoc' (a u (b u c)) =  ((a u b) u c)
  by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)

lemma register_assoc[simp]: register assoc
  unfolding assoc_def
  by force

lemma register_assoc'[simp]: register assoc'
  unfolding assoc'_def 
  by force

lemma pair_o_assoc[simp]:
  assumes [simp]: compatible F G compatible G H compatible F H
  shows (F; (G; H))  assoc = ((F; G); H)
proof (rule tensor_extensionality3')
  show register ((F; (G; H))  assoc)
    by simp
  show register ((F; G); H)
    by simp
  show ((F; (G; H))  assoc) ((f u g) u h) = ((F; G); H) ((f u g) u h) for f g h
    by (simp add: register_pair_apply assoc_apply comp_update_assoc)
qed

lemma pair_o_assoc'[simp]:
  assumes [simp]: compatible F G compatible G H compatible F H
  shows ((F; G); H)  assoc' = (F; (G; H))
proof (rule tensor_extensionality3)
  show register (((F; G); H)  assoc')
    by simp
  show register (F; (G; H))
    by simp
  show (((F; G); H)  assoc') (f u g u h) = (F; (G; H)) (f u g u h) for f g h
    by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
qed

lemma assoc'_o_assoc[simp]: assoc' o assoc = id
  apply (rule tensor_extensionality3')
  by auto

lemma assoc'_assoc[simp]: assoc' (assoc x) = x
  by (simp add: pointfree_idE)

lemma assoc_o_assoc'[simp]: assoc o assoc' = id
  apply (rule tensor_extensionality3)
  by auto

lemma assoc_assoc'[simp]: assoc (assoc' x) = x
  by (simp add: pointfree_idE)

lemma inv_assoc[simp]: inv assoc = assoc'
  using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast

lemma inv_assoc'[simp]: inv assoc' = assoc
  by (simp add: inv_equality)

lemma [simp]: bij assoc
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

lemma [simp]: bij assoc'
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

subsection Iso-registers

definition iso_register F  register F  (G. register G  F o G = id  G o F = id)
  for F :: _::type update  _::type update

lemma iso_registerI:
  assumes register F register G F o G = id G o F = id
  shows iso_register F
  using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast

lemma iso_register_inv: iso_register F  iso_register (inv F)
  by (metis inv_unique_comp iso_register_def)

lemma iso_register_inv_comp1: iso_register F  inv F o F = id
  using inv_unique_comp iso_register_def by blast

lemma iso_register_inv_comp2: iso_register F  F o inv F = id
  using inv_unique_comp iso_register_def by blast


lemma iso_register_id[simp]: iso_register id
  by (simp add: iso_register_def)

lemma iso_register_is_register: iso_register F  register F
  using iso_register_def by blast

lemma iso_register_comp[simp]:
  assumes [simp]: iso_register F iso_register G
  shows iso_register (F o G)
proof -
  from assms obtain F' G' where [simp]: register F' register G' F o F' = id F' o F = id
    G o G' = id G' o G = id
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=G' o F'])
       apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
     apply (metis F  F' = id G  G' = id fcomp_assoc fcomp_comp id_fcomp)
    by (metis (no_types, lifting) F  F' = id F'  F = id G'  G = id fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed


lemma iso_register_tensor_is_iso_register[simp]:
  assumes [simp]: iso_register F iso_register G
  shows iso_register (F r G)
proof -
  from assms obtain F' G' where [simp]: register F' register G' F o F' = id F' o F = id
    G o G' = id G' o G = id
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=F' r G'])
    by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed

lemma iso_register_bij: iso_register F  bij F
  using iso_register_def o_bij by auto

lemma inv_register_tensor[simp]: 
  assumes [simp]: iso_register F iso_register G
  shows inv (F r G) = inv F r inv G
  apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij 
              simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                    iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
  by (metis eq_id_iff register_tensor_id)

lemma iso_register_swap[simp]: iso_register swap
  apply (rule iso_registerI[of _ swap])
  by auto

lemma iso_register_assoc[simp]: iso_register assoc
  apply (rule iso_registerI[of _ assoc'])
  by auto

lemma iso_register_assoc'[simp]: iso_register assoc'
  apply (rule iso_registerI[of _ assoc])
  by auto

definition equivalent_registers F G  (register F  (I. iso_register I  F o I = G))
  for F G :: _::type update  _::type update

lemma iso_register_equivalent_id[simp]: equivalent_registers id F  iso_register F
  by (simp add: equivalent_registers_def)

lemma equivalent_registersI:
  assumes register F
  assumes iso_register I
  assumes F o I = G
  shows equivalent_registers F G
  using assms unfolding equivalent_registers_def by blast

lemma equivalent_registers_register_left: equivalent_registers F G  register F
  using equivalent_registers_def by auto

lemma equivalent_registers_register_right: register G if equivalent_registers F G
  by (metis equivalent_registers_def iso_register_def register_comp that)

lemma equivalent_registers_sym:
  assumes equivalent_registers F G
  shows equivalent_registers G F
  by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)

lemma equivalent_registers_trans[trans]: 
  assumes equivalent_registers F G and equivalent_registers G H
  shows equivalent_registers F H
proof -
  from assms have [simp]: register F register G
    by (auto simp: equivalent_registers_def)
  from assms(1) obtain I where [simp]: iso_register I and F o I = G
    using equivalent_registers_def by blast
  from assms(2) obtain J where [simp]: iso_register J and G o J = H
    using equivalent_registers_def by blast
  have register F
    by (auto simp: equivalent_registers_def)
  moreover have iso_register (I o J)
    using iso_register I iso_register J iso_register_comp by blast
  moreover have F o (I o J) = H
    by (simp add: F  I = G G  J = H o_assoc)
  ultimately show ?thesis
    by (rule equivalent_registersI)
qed

lemma equivalent_registers_assoc[simp]:
  assumes [simp]: compatible F G compatible F H compatible G H
  shows equivalent_registers (F;(G;H)) ((F;G);H)
  apply (rule equivalent_registersI[where I=assoc])
  by auto

lemma equivalent_registers_pair_right:
  assumes [simp]: compatible F G
  assumes eq: equivalent_registers G H
  shows equivalent_registers (F;G) (F;H)
proof -
  from eq obtain I where [simp]: iso_register I and G o I = H
    by (metis equivalent_registers_def)
  then have *: (F;G)  (id r I) = (F;H)
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=id r I])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_pair_left:
  assumes [simp]: compatible F G
  assumes eq: equivalent_registers F H
  shows equivalent_registers (F;G) (H;G)
proof -
  from eq obtain I where [simp]: iso_register I and F o I = H
    by (metis equivalent_registers_def)
  then have *: (F;G)  (I r id) = (H;G)
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=I r id])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_comp:
  assumes register H
  assumes equivalent_registers F G
  shows equivalent_registers (H o F) (H o G)
  by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)

subsection Compatibility simplification

text The simproc compatibility_warn› produces helpful warnings for subgoals of the form
   termcompatible x y that are probably unsolvable due to missing declarations of 
   variable compatibility facts. Same for subgoals of the form termregister x.
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = 
let val thy_string = Markup.markup (Theory.get_markup theory) (Context.theory_name theory)
in
fn m => fn ctxt => fn ct => let
  val (x,y) = case Thm.term_of ct of
                 Const(const_namecompatible,_ ) $ x $ y => (x, SOME y)
               | Const(const_nameregister,_ ) $ x => (x, NONE)
  val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
  fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
  val _ = case (x,y) of
        (Free(n,T), SOME (Free(n',T'))) => 
            if String.isPrefix ":" n orelse String.isPrefix ":" n' then 
                      w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else if n=n' then (if T=T' then () 
                          else w ("In simplification subgoal " ^ Lazy.force str ^ 
                               ", variables have same name and different types.\n" ^
                               "Probably something is wrong."))
                    else w ("Simplification subgoal " ^ Lazy.force str ^ 
                            " occurred but cannot be solved.\n" ^
                            "Please add assumption/fact  [simp]: ‹" ^ Lazy.force str ^ 
                            "›  somewhere.")
      | (Free(n,T), NONE) => 
            if String.isPrefix ":" n then 
                      w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                    "Please add assumption/fact  [simp]: ‹" ^ Lazy.force str ^ "›  somewhere.")
      | _ => ()
  in NONE end
end


named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule

lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
  asm_rl[of compatible _ _] asm_rl[of iso_register _] asm_rl[of register _] iso_register_inv

text The following declares an attribute [register]›. When the attribute is applied to a fact
  of the form termregister F, termiso_register F, termcompatible F G or a conjunction of these,
  then those facts are added to the simplifier together with some derived theorems
  (e.g., termcompatible F G also adds termregister F).

  In theory Laws_Complement›, support for termis_unit_register F and termcomplements F G is
  added to this attribute.

setup 
let
fun add thm results = 
  Net.insert_term (K true) (Thm.concl_of thm, thm) results
  handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
  NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
  results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
  val ctxt = Context.proof_of context
  val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
  val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
  val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
  (* val _ = print thms *)
  in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup bindingregister
 (Scan.succeed (Thm.declaration_attribute declare))
  "Add register-related rules to the simplifier"
end


subsection Notation

no_notation map_comp (infixl "*u" 55)
no_notation tensor_update (infixr "u" 70)

bundle register_notation begin
notation register_tensor (infixr "r" 70)
notation register_pair ("'(_;_')")
end

bundle no_register_notation begin
no_notation register_tensor (infixr "r" 70)
no_notation register_pair ("'(_;_')")
end

end

Theory Misc

section Miscellaneous facts

text This theory proves various facts that are not directly related to this developments 
but do not occur in the imported theories.

theory Misc
  imports
    Complex_Bounded_Operators.Cblinfun_Code
    "HOL-Library.Z2"
    Jordan_Normal_Form.Matrix
begin

― ‹Remove notation that collides with the notation we use
no_notation Order.top ("ı")
no_notation m_inv ("invı _" [81] 80)
unbundle no_vec_syntax
unbundle no_inner_syntax

― ‹Import notation from Bounded Operator and Jordan Normal Form libraries
unbundle cblinfun_notation
unbundle jnf_notation


abbreviation "butterket i j  butterfly (ket i) (ket j)"
abbreviation "selfbutterket i  butterfly (ket i) (ket i)"

text The following declares the ML antiquotation ‹fact›. In ML code,
  ‹@{fact f}› for a theorem/fact name f is replaced by an ML string
  containing a printable(!) representation of fact. (I.e.,
  if you print that string using writeln, the user can ctrl-click on it.)

  This is useful when constructing diagnostic messages in ML code, e.g., 
  ‹"Use the theorem " ^ @{fact thmname} ^ "here."›

setup ML_Antiquotation.inline_embedded bindingfact
((Args.context -- Scan.lift Args.name_position) >> (fn (ctxt,namepos) => let
  val facts = Proof_Context.facts_of ctxt
  val fullname = Facts.check (Context.Proof ctxt) facts namepos
  val (markup, shortname) = Proof_Context.markup_extern_fact ctxt fullname
  val string = Markup.markups markup shortname
  in ML_Syntax.print_string string end
))



instantiation bit :: enum begin
definition "enum_bit = [0::bit,1]"
definition "enum_all_bit P  P (0::bit)  P 1"
definition "enum_ex_bit P  P (0::bit)  P 1"
instance
  apply intro_classes
     apply (auto simp: enum_bit_def enum_all_bit_def enum_ex_bit_def)
   apply (metis bit_not_one_iff)
  by (metis bit_not_zero_iff)
end

lemma card_bit[simp]: "CARD(bit) = 2"
  using card_2_iff' by force

instantiation bit :: card_UNIV begin
definition "finite_UNIV = Phantom(bit) True"
definition "card_UNIV = Phantom(bit) 2"
instance
  apply intro_classes
  by (simp_all add: finite_UNIV_bit_def card_UNIV_bit_def)
end

lemma mat_of_rows_list_carrier[simp]:
  "mat_of_rows_list n vs  carrier_mat (length vs) n"
  "dim_row (mat_of_rows_list n vs) = length vs"
  "dim_col (mat_of_rows_list n vs) = n"
  unfolding mat_of_rows_list_def by auto

lemma apply_id_cblinfun[simp]: (*V) id_cblinfun = id
  by auto

text Overriding \theoryComplex_Bounded_Operators.Complex_Bounded_Linear_Function.termsandwich.
      The latter is the same function but defined as a typ(_,_) cblinfun which is less convenient for us.
definition sandwich where sandwich a b = a oCL b oCL a*

lemma clinear_sandwich[simp]: clinear (sandwich a)
  apply (rule clinearI)
   apply (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right sandwich_def)
  by (simp add: sandwich_def)

lemma sandwich_id[simp]: sandwich id_cblinfun = id
  by (auto simp: sandwich_def)

lemma mat_of_cblinfun_sandwich:
  fixes a :: "(_::onb_enum, _::onb_enum) cblinfun"
  shows mat_of_cblinfun (sandwich a b) = (let a' = mat_of_cblinfun a in a' * mat_of_cblinfun b * mat_adjoint a')
  by (simp add: mat_of_cblinfun_compose sandwich_def Let_def mat_of_cblinfun_adj)

lemma prod_cases3' [cases type]:
  obtains (fields) a b c where "y = ((a, b), c)"
  by (cases y, case_tac a) blast

lemma lift_cblinfun_comp:
  assumes a oCL b = c
  shows a oCL b = c
    and a oCL (b oCL d) = c oCL d
    and a *S (b *S S) = c *S S
    and a *V (b *V x) = c *V x
     apply (fact assms)
    apply (simp add: assms cblinfun_assoc_left(1))
  using assms cblinfun_assoc_left(2) apply force
  using assms by force

text We define the following abbreviations:
 mutually f (x1,x2,…,xn)› expands to the conjuction of all termf xi xj with termij.
 each f (x1,x2,…,xn)› expands to the conjuction of all termf xi.

syntax "_mutually" :: "'a  args  'b" ("mutually _ '(_')")
syntax "_mutually2" :: "'a  'b  args  args  'c"

translations "mutually f (x)" => "CONST True"
translations "mutually f (_args x y)" => "f x y  f y x"
translations "mutually f (_args x (_args x' xs))" => "_mutually2 f x (_args x' xs) (_args x' xs)"
translations "_mutually2 f x y zs" => "f x y  f y x  _mutually f zs"
translations "_mutually2 f x (_args y ys) zs" => "f x y  f y x  _mutually2 f x ys zs"

syntax "_each" :: "'a  args  'b" ("each _ '(_')")
translations "each f (x)" => "f x"
translations "_each f (_args x xs)" => "f x  _each f xs"


lemma enum_inj:
  assumes "i < CARD('a)" and "j < CARD('a)"
  shows "(Enum.enum ! i :: 'a::enum) = Enum.enum ! j  i = j"
  using inj_on_nth[OF enum_distinct, where I={..<CARD('a)}]
  using assms by (auto dest: inj_onD simp flip: card_UNIV_length_enum)


lemma [simp]: "dim_col (mat_adjoint m) = dim_row m"
  unfolding mat_adjoint_def by simp
lemma [simp]: "dim_row (mat_adjoint m) = dim_col m"
  unfolding mat_adjoint_def by simp

lemma invI: 
  assumes inj f
  assumes x = f y
  shows inv f x = y
  by (simp add: assms(1) assms(2))

instantiation prod :: (default,default) default begin
definition default_prod = (default, default)
instance..
end

instance bit :: default..

lemma surj_from_comp:
  assumes surj (g o f)
  assumes inj g
  shows surj f
  by (metis assms(1) assms(2) f_inv_into_f fun.set_map inj_image_mem_iff iso_tuple_UNIV_I surj_iff_all)

lemma double_exists: (x y. Q x y)  (z. Q (fst z) (snd z))
  by simp

end

Theory Classical_Extra

section Derived facts about classical registers

theory Classical_Extra
  imports Laws_Classical Misc
begin

lemma register_from_getter_setter_of_getter_setter[simp]: register_from_getter_setter (getter F) (setter F) = F if register F
  by (metis getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter that)

lemma valid_getter_setter_getter_setter[simp]: valid_getter_setter (getter F) (setter F) if register F
  by (metis getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter that)

lemma register_register_from_getter_setter[simp]: register (register_from_getter_setter g s) if valid_getter_setter g s
  using register_def that by blast

definition total_fun f = (x. f x  None)

lemma register_total:
  assumes register F
  assumes total_fun a
  shows total_fun (F a)
  using assms 
  by (auto simp: register_def total_fun_def register_from_getter_setter_def option.case_eq_if)

lemma register_apply:
  assumes register F
  shows Some o register_apply F a = F (Some o a)
proof -
  have total_fun (F (Some o a))
    using assms apply (rule register_total)
    by (auto simp: total_fun_def)
  then show ?thesis
    by (auto simp: register_apply_def dom_def total_fun_def)
qed

lemma register_empty:
  assumes preregister F
  shows F Map.empty = Map.empty
  using assms unfolding preregister_def by auto

lemma compatible_setter:
  fixes F :: ('a,'c) preregister and G :: ('b,'c) preregister
  assumes [simp]: register F register G
  shows compatible F G  (a b. setter F a o setter G b = setter G b o setter F a)
proof (intro allI iffI)
  fix a b
  assume compatible F G
  then show setter F a o setter G b = setter G b o setter F a
    apply (rule_tac compatible_setter)
    unfolding compatible_def by auto
next
  assume commute[rule_format, THEN fun_cong, unfolded o_def]: a b. setter F a  setter G b = setter G b  setter F a
  have valid_getter_setter (getter F) (setter F)
    by auto
  then have F a m G b = G b m F a for a b
    apply (subst (2) register_from_getter_setter_of_getter_setter[symmetric, of F], simp)
    apply (subst (1) register_from_getter_setter_of_getter_setter[symmetric, of F], simp)
    apply (subst (2) register_from_getter_setter_of_getter_setter[symmetric, of G], simp)
    apply (subst (1) register_from_getter_setter_of_getter_setter[symmetric, of G], simp)
    unfolding register_from_getter_setter_def valid_getter_setter_def
    apply (auto intro!: ext simp: option.case_eq_if map_comp_def) (* Sledgehammer: *)
          apply ((metis commute option.distinct option.simps)+)[4]
      apply (smt (verit, ccfv_threshold) assms(2) commute valid_getter_setter_def valid_getter_setter_getter_setter)
     apply (smt (verit, ccfv_threshold) assms(2) commute valid_getter_setter_def valid_getter_setter_getter_setter)
    by (smt (verit, del_insts) assms(2) commute option.inject valid_getter_setter_def valid_getter_setter_getter_setter)
  then show compatible F G
    unfolding compatible_def by auto
qed

lemma register_from_getter_setter_compatibleI[intro]:
  assumes [simp]: valid_getter_setter g s valid_getter_setter g' s'
  assumes x y m. s x (s' y m) = s' y (s x m)
  shows compatible (register_from_getter_setter g s) (register_from_getter_setter g' s')
  apply (subst compatible_setter)
  using assms by auto

lemma separating_update1:
  separating TYPE(_) {update1 x y | x y. True}
  by (smt (verit) mem_Collect_eq separating_def update1_extensionality)

definition "permutation_register (p::'b'a) = register_from_getter_setter p (λa _. inv p a)"

lemma permutation_register_register[simp]: 
  fixes p :: "'b  'a"
  assumes [simp]: "bij p"
  shows "register (permutation_register p)"
  apply (auto intro!: register_register_from_getter_setter simp: permutation_register_def valid_getter_setter_def bij_inv_eq_iff)
  by (meson assms bij_inv_eq_iff)

lemma getter_permutation_register: bij p  getter (permutation_register p) = p
  by (smt (verit, ccfv_threshold) bij_inv_eq_iff getter_of_register_from_getter_setter permutation_register_def valid_getter_setter_def)

lemma setter_permutation_register: bij p  setter (permutation_register p) a m = inv p a
  by (metis bij_inv_eq_iff getter_permutation_register permutation_register_register valid_getter_setter_def valid_getter_setter_getter_setter)

definition empty_var :: 'a::{CARD_1} update  'b update where
  "empty_var = register_from_getter_setter (λ_. undefined) (λ_ m. m)"

lemma valid_empty_var[simp]: valid_getter_setter (λ_. (undefined::_::CARD_1)) (λ_ m. m)
  by (simp add: valid_getter_setter_def)

lemma register_empty_var[simp]: register empty_var
  using empty_var_def register_def valid_empty_var by blast

lemma getter_empty_var[simp]: getter empty_var m = undefined
  by (rule everything_the_same)

lemma setter_empty_var[simp]: setter empty_var a m = m
  by (simp add: empty_var_def setter_of_register_from_getter_setter)

lemma empty_var_compatible[simp]: compatible empty_var X if [simp]: register X
  apply (subst compatible_setter) by auto

lemma empty_var_compatible'[simp]: register X  compatible X empty_var
  using compatible_sym empty_var_compatible by blast

paragraph Example

record memory = 
  x :: "int*int"
  y :: nat

definition "X = register_from_getter_setter x (λa b. bx:=a)"
definition "Y = register_from_getter_setter y (λa b. by:=a)"

lemma validX[simp]: valid_getter_setter x (λa b. bx:=a)
  unfolding valid_getter_setter_def by auto

lemma registerX[simp]: register X
  using X_def register_def validX by blast

lemma validY[simp]: valid_getter_setter y (λa b. by:=a)
  unfolding valid_getter_setter_def by auto

lemma registerY[simp]: register Y
  using Y_def register_def validY by blast

lemma compatibleXY[simp]: compatible X Y
  unfolding X_def Y_def by auto

end

Theory Finite_Tensor_Product

section Tensor products (finite dimensional)

theory Finite_Tensor_Product
  imports Complex_Bounded_Operators.Complex_L2 Misc
begin

declare cblinfun.scaleC_right[simp]

unbundle cblinfun_notation
no_notation m_inv ("invı _" [81] 80)

lift_definition tensor_ell2 :: 'a::finite ell2  'b::finite ell2  ('a×'b) ell2 (infixr "s" 70) is
  λψ φ (i,j). ψ i * φ j
  by simp

lemma tensor_ell2_add2: tensor_ell2 a (b + c) = tensor_ell2 a b + tensor_ell2 a c
  apply transfer apply (rule ext) apply (auto simp: case_prod_beta)
  by (meson algebra_simps)

lemma tensor_ell2_add1: tensor_ell2 (a + b) c = tensor_ell2 a c + tensor_ell2 b c
  apply transfer apply (rule ext) apply (auto simp: case_prod_beta)
  by (simp add: vector_space_over_itself.scale_left_distrib)

lemma tensor_ell2_scaleC2: tensor_ell2 a (c *C b) = c *C tensor_ell2 a b
  apply transfer apply (rule ext) by (auto simp: case_prod_beta)

lemma tensor_ell2_scaleC1: tensor_ell2 (c *C a) b = c *C tensor_ell2 a b
  apply transfer apply (rule ext) by (auto simp: case_prod_beta)

lemma tensor_ell2_inner_prod[simp]: tensor_ell2 a b, tensor_ell2 c d = a,c * b,d
  apply transfer
  by (auto simp: case_prod_beta sum_product sum.cartesian_product mult.assoc mult.left_commute)

lemma clinear_tensor_ell21: "clinear (λb. tensor_ell2 a b)"
  apply (rule clinearI; transfer)
   apply (auto simp: case_prod_beta)
  by (simp add: cond_case_prod_eta algebra_simps)

lemma clinear_tensor_ell22: "clinear (λa. tensor_ell2 a b)"
  apply (rule clinearI; transfer)
   apply (auto simp: case_prod_beta)
  by (simp add: case_prod_beta' algebra_simps)

lemma tensor_ell2_ket[simp]: "tensor_ell2 (ket i) (ket j) = ket (i,j)"
  apply transfer by auto


definition tensor_op :: ('a ell2, 'b::finite ell2) cblinfun  ('c ell2, 'd::finite ell2) cblinfun
       (('a×'c) ell2, ('b×'d) ell2) cblinfun (infixr "o" 70) where
  tensor_op M N = (SOME P. a c. P *V (ket (a,c))
      = tensor_ell2 (M *V ket a) (N *V ket c))

lemma tensor_op_ket: 
  fixes a :: 'a::finite and b :: 'b and c :: 'c::finite and d :: 'd
  shows tensor_op M N *V (ket (a,c)) = tensor_ell2 (M *V ket a) (N *V ket c)
proof -
  define S :: ('a×'c) ell2 set where "S = ket ` UNIV"
  define φ where φ = (λ(a,c). tensor_ell2 (M *V ket a) (N *V ket c))
  define φ' where φ' = φ  inv ket

  have def: tensor_op M N = (SOME P. a c. P *V (ket (a,c)) = φ (a,c))
    unfolding tensor_op_def φ_def by auto

  have cindependent S
    using S_def cindependent_ket by blast
  moreover have cspan S = UNIV
    using S_def cspan_range_ket_finite by blast
  ultimately have "cblinfun_extension_exists S φ'"
    by (rule cblinfun_extension_exists_finite_dim)
  then have "P. xS. P *V x = φ' x"
    unfolding cblinfun_extension_exists_def by auto
  then have ex: P. a c. P *V ket (a,c) = φ (a,c)
    by (metis S_def φ'_def comp_eq_dest_lhs inj_ket inv_f_f rangeI)


  then have tensor_op M N *V (ket (a,c)) = φ (a,c)
    unfolding def apply (rule someI2_ex[where P=λP. a c. P *V (ket (a,c)) = φ (a,c)])
    by auto
  then show ?thesis
    unfolding φ_def by auto
qed


lemma tensor_op_ell2: "tensor_op A B *V tensor_ell2 ψ φ = tensor_ell2 (A *V ψ) (B *V φ)"
proof -
  have 1: clinear (λa. tensor_op A B *V tensor_ell2 a (ket b)) for b
    by (auto intro!: clinearI simp: tensor_ell2_add1 tensor_ell2_scaleC1 cblinfun.add_right)
  have 2: clinear (λa. tensor_ell2 (A *V a) (B *V ket b)) for b
    by (auto intro!: clinearI simp: tensor_ell2_add1 tensor_ell2_scaleC1 cblinfun.add_right)
  have 3: clinear (λa. tensor_op A B *V tensor_ell2 ψ a)
    by (auto intro!: clinearI simp: tensor_ell2_add2 tensor_ell2_scaleC2 cblinfun.add_right)
  have 4: clinear (λa. tensor_ell2 (A *V ψ) (B *V a))
    by (auto intro!: clinearI simp: tensor_ell2_add2 tensor_ell2_scaleC2 cblinfun.add_right)

  have eq_ket_ket: tensor_op A B *V tensor_ell2 (ket a) (ket b) = tensor_ell2 (A *V ket a) (B *V ket b) for a b
    by (simp add: tensor_op_ket)
  have eq_ket: tensor_op A B *V tensor_ell2 ψ (ket b) = tensor_ell2 (A *V ψ) (B *V ket b) for b
    apply (rule fun_cong[where x=ψ])
    using 1 2 eq_ket_ket by (rule clinear_equal_ket)
  show ?thesis 
    apply (rule fun_cong[where x=φ])
    using 3 4 eq_ket by (rule clinear_equal_ket)
qed

lemma comp_tensor_op: "(tensor_op a b) oCL (tensor_op c d) = tensor_op (a oCL c) (b oCL d)"
  for a :: "'e::finite ell2 CL 'c::finite ell2" and b :: "'f::finite ell2 CL 'd::finite ell2" and
      c :: "'a::finite ell2 CL 'e ell2" and d :: "'b::finite ell2 CL 'f ell2"
  apply (rule equal_ket)
  apply (rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
  by (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun_apply_cblinfun_compose)


lemma tensor_op_cbilinear: cbilinear (tensor_op :: 'a::finite ell2 CL 'b::finite ell2
                                                  'c::finite ell2 CL 'd::finite ell2  _)
proof -
  have clinear (λb::'c ell2 CL 'd ell2. tensor_op a b) for a :: 'a ell2 CL 'b ell2
    apply (rule clinearI)
     apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
     apply (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun.add_left tensor_ell2_add2)
    apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
    by (simp add: scaleC_cblinfun.rep_eq tensor_ell2_scaleC2 tensor_op_ket)

  moreover have clinear (λa::'a::finite ell2 CL 'b::finite ell2. tensor_op a b) for b :: 'c ell2 CL 'd ell2
    apply (rule clinearI)
     apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
     apply (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun.add_left tensor_ell2_add1)
    apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
    by (simp add: scaleC_cblinfun.rep_eq tensor_ell2_scaleC1 tensor_op_ket)

  ultimately show ?thesis
    unfolding cbilinear_def by auto
qed


lemma tensor_butter: tensor_op (butterket i j) (butterket k l) = butterket (i,k) (j,l)
  for i :: "_" and j :: "_::finite" and k :: "_" and l :: "_::finite"
  apply (rule equal_ket, rename_tac x, case_tac x)
  apply (auto simp flip: tensor_ell2_ket simp: cblinfun_apply_cblinfun_compose tensor_op_ell2 butterfly_def)
  by (auto simp: tensor_ell2_scaleC1 tensor_ell2_scaleC2)

lemma cspan_tensor_op: cspan {tensor_op (butterket i j) (butterket k l)| i (j::_::finite) k (l::_::finite). True} = UNIV
  unfolding tensor_butter
  apply (subst cspan_butterfly_ket[symmetric])
  by (metis surj_pair)

lemma cindependent_tensor_op: cindependent {tensor_op (butterket i j) (butterket k l)| i (j::_::finite) k (l::_::finite). True}
  unfolding tensor_butter
  using cindependent_butterfly_ket
  by (smt (z3) Collect_mono_iff complex_vector.independent_mono)


lemma tensor_extensionality:
  fixes F G :: ((('a::finite × 'b::finite) ell2) CL (('c::finite × 'd::finite) ell2))  'e::complex_vector
  assumes [simp]: "clinear F" "clinear G"
  assumes tensor_eq: "(a b. F (tensor_op a b) = G (tensor_op a b))"
  shows "F = G"
proof (rule ext, rule complex_vector.linear_eq_on_span[where f=F and g=G])
  show clinear F and clinear G
    using assms by (simp_all add: cbilinear_def)
  show x  cspan  {tensor_op (butterket i j) (butterket k l)| i j k l. True} 
    for x :: ('a × 'b) ell2 CL ('c × 'd) ell2
    using cspan_tensor_op by auto
  show F x = G x if x  {tensor_op (butterket i j) (butterket k l) |i j k l. True} for x
    using that by (auto simp: tensor_eq)
qed

lemma tensor_id[simp]: tensor_op id_cblinfun id_cblinfun = id_cblinfun
  apply (rule equal_ket, rename_tac x, case_tac x)
  by (simp flip: tensor_ell2_ket add: tensor_op_ell2)

lemma tensor_op_adjoint: (tensor_op a b)* = tensor_op (a*) (b*)
  apply (rule cinner_ket_adjointI[symmetric])
  apply (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)
  by (simp add: cinner_adj_left)

lemma tensor_butterfly[simp]: "tensor_op (butterfly ψ ψ') (butterfly φ φ') = butterfly (tensor_ell2 ψ φ) (tensor_ell2 ψ' φ')"
  apply (rule equal_ket, rename_tac x, case_tac x)
  by (simp flip: tensor_ell2_ket add: tensor_op_ell2 butterfly_def
      cblinfun_apply_cblinfun_compose tensor_ell2_scaleC1 tensor_ell2_scaleC2)

definition tensor_lift :: (('a1::finite ell2 CL 'a2::finite ell2)  ('b1::finite ell2 CL 'b2::finite ell2)  'c)
                         ((('a1×'b1) ell2 CL ('a2×'b2) ell2)  'c::complex_vector) where
  "tensor_lift F2 = (SOME G. clinear G  (a b. G (tensor_op a b) = F2 a b))"

lemma 
  fixes F2 :: "'a::finite ell2 CL 'b::finite ell2
             'c::finite ell2 CL 'd::finite ell2
             'e::complex_normed_vector"
  assumes "cbilinear F2"
  shows tensor_lift_clinear: "clinear (tensor_lift F2)"
    and tensor_lift_correct:  (λa b. tensor_lift F2 (tensor_op a b)) = F2
proof -
  define F2' t4 φ where
    F2' = tensor_lift F2 and
    t4 = (λ(i,j,k,l). tensor_op (butterket i j) (butterket k l)) and
    φ m = (let (i,j,k,l) = inv t4 m in F2 (butterket i j) (butterket k l)) for m
  have t4inj: "x = y" if "t4 x = t4 y" for x y
  proof (rule ccontr)
    obtain i  j  k  l  where x: "x = (i,j,k,l)" by (meson prod_cases4) 
    obtain i' j' k' l' where y: "y = (i',j',k',l')" by (meson prod_cases4) 
    have 1: "bra (i,k) *V t4 x *V ket (j,l) = 1"
      by (auto simp: t4_def x tensor_op_ell2 butterfly_def cinner_ket simp flip: tensor_ell2_ket)
    assume x  y
    then have 2: "bra (i,k) *V t4 y *V ket (j,l) = 0"
      by (auto simp: t4_def x y tensor_op_ell2 butterfly_def cblinfun_apply_cblinfun_compose cinner_ket
               simp flip: tensor_ell2_ket)
    from 1 2 that
    show False
      by auto
  qed
  have φ (tensor_op (butterket i j) (butterket k l)) = F2 (butterket i j) (butterket k l) for i j k l
    apply (subst asm_rl[of tensor_op (butterket i j) (butterket k l) = t4 (i,j,k,l)])
     apply (simp add: t4_def)
    by (auto simp add: injI t4inj inv_f_f φ_def)

  have *: range t4 = {tensor_op (butterket i j) (butterket k l) |i j k l. True}
    apply (auto simp: case_prod_beta t4_def)
    using image_iff by fastforce

  have "cblinfun_extension_exists (range t4) φ"
    thm cblinfun_extension_exists_finite_dim[where φ=φ]
    apply (rule cblinfun_extension_exists_finite_dim)
     apply auto unfolding * 
    using cindependent_tensor_op
    using cspan_tensor_op
    by auto

  then obtain G where G: G *V (t4 (i,j,k,l)) = F2 (butterket i j) (butterket k l) for i j k l
    apply atomize_elim
    unfolding cblinfun_extension_exists_def
    apply auto
    by (metis (no_types, lifting) t4inj φ_def f_inv_into_f rangeI split_conv)

  have *: G *V tensor_op (butterket i j) (butterket k l) = F2 (butterket i j) (butterket k l) for i j k l
    using G by (auto simp: t4_def)
  have *: G *V tensor_op a (butterket k l) = F2 a (butterket k l) for a k l
    apply (rule complex_vector.linear_eq_on_span[where g=λa. F2 a _ and B={butterket k l|k l. True}])
    unfolding cspan_butterfly_ket
    using * apply (auto intro!: clinear_compose[unfolded o_def, where f=λa. tensor_op a _ and g=(*V) G])
     apply (metis cbilinear_def tensor_op_cbilinear)
    using assms unfolding cbilinear_def by blast
  have G_F2: G *V tensor_op a b = F2 a b for a b
    apply (rule complex_vector.linear_eq_on_span[where g=F2 a and B={butterket k l|k l. True}])
    unfolding cspan_butterfly_ket
    using * apply (auto simp: cblinfun.add_right clinearI
                        intro!: clinear_compose[unfolded o_def, where f=tensor_op a and g=(*V) G])
    apply (meson cbilinear_def tensor_op_cbilinear)
    using assms unfolding cbilinear_def by blast

  have clinear F2'  (a b. F2' (tensor_op a b) = F2 a b)
    unfolding F2'_def tensor_lift_def 
    apply (rule someI[where x=(*V) G and P=λG. clinear G  (a b. G (tensor_op a b) = F2 a b)])
    using G_F2 by (simp add: cblinfun.add_right clinearI)

  then show clinear F2' and (λa b. tensor_lift F2 (tensor_op a b)) = F2
    unfolding F2'_def by auto
qed

lift_definition assoc_ell20 :: (('a::finite×'b::finite)×'c::finite) ell2  ('a×('b×'c)) ell2 is
  λf (a,(b,c)). f ((a,b),c)
  by auto

lift_definition assoc_ell20' :: ('a::finite×('b::finite×'c::finite)) ell2  (('a×'b)×'c) ell2 is
  λf ((a,b),c). f (a,(b,c))
  by auto

lift_definition assoc_ell2 :: (('a::finite×'b::finite)×'c::finite) ell2 CL ('a×('b×'c)) ell2
  is assoc_ell20
  apply (subst bounded_clinear_finite_dim)
   apply (rule clinearI; transfer)
  by auto

lift_definition assoc_ell2' :: ('a::finite×('b::finite×'c::finite)) ell2 CL (('a×'b)×'c) ell2 is
  assoc_ell20'
  apply (subst bounded_clinear_finite_dim)
   apply (rule clinearI; transfer)
  by auto

lemma assoc_ell2_tensor: assoc_ell2 *V tensor_ell2 (tensor_ell2 a b) c = tensor_ell2 a (tensor_ell2 b c)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinear_tensor_ell22)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=c])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
  unfolding assoc_ell2.rep_eq
  apply transfer
  by auto

lemma assoc_ell2'_tensor: assoc_ell2' *V tensor_ell2 a (tensor_ell2 b c) = tensor_ell2 (tensor_ell2 a b) c
  apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=c])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
  unfolding assoc_ell2'.rep_eq
  apply transfer
  by auto

lemma adjoint_assoc_ell2[simp]: assoc_ell2* = assoc_ell2'
proof (rule adjoint_eqI[symmetric])
  have [simp]: clinear (cinner (assoc_ell2' *V x)) for x :: ('a × 'b × 'c) ell2
    by (metis (no_types, lifting) cblinfun.add_right cinner_scaleC_right clinearI complex_scaleC_def mult.comm_neutral of_complex_def vector_to_cblinfun_adj_apply)
  have [simp]: clinear (λa. x, assoc_ell2 *V a) for x :: ('a × 'b × 'c) ell2
    by (simp add: cblinfun.add_right cinner_add_right clinearI)
  have [simp]: antilinear (λa. a, y) for y :: ('a × 'b × 'c) ell2
    using bounded_antilinear_cinner_left bounded_antilinear_def by blast
  have [simp]: antilinear (λa. assoc_ell2' *V a, y) for y :: (('a × 'b) × 'c) ell2
    by (simp add: cblinfun.add_right cinner_add_left antilinearI)
  have assoc_ell2' *V (ket x), ket y = ket x, assoc_ell2 *V ket y for x :: 'a × 'b × 'c and y
    apply (cases x, cases y)
    by (simp flip: tensor_ell2_ket add: assoc_ell2'_tensor assoc_ell2_tensor)
  then have assoc_ell2' *V (ket x), y = ket x, assoc_ell2 *V y for x :: 'a × 'b × 'c and y
    by (rule clinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
  then show assoc_ell2' *V x, y = x, assoc_ell2 *V y for x :: ('a × 'b × 'c) ell2 and y
    by (rule antilinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
qed

lemma adjoint_assoc_ell2'[simp]: assoc_ell2'* = assoc_ell2
  by (simp flip: adjoint_assoc_ell2)


lift_definition swap_ell20 :: ('a::finite×'b::finite) ell2  ('b×'a) ell2 is
  λf (a,b). f (b,a)
  by auto

lift_definition swap_ell2 :: ('a::finite×'b::finite) ell2 CL ('b×'a) ell2
  is swap_ell20
  apply (subst bounded_clinear_finite_dim)
   apply (rule clinearI; transfer)
  by auto

lemma swap_ell2_tensor[simp]: swap_ell2 *V tensor_ell2 a b = tensor_ell2 b a
  apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinear_tensor_ell21)
  apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
   apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  unfolding swap_ell2.rep_eq
  apply transfer
  by auto

lemma adjoint_swap_ell2[simp]: swap_ell2* = swap_ell2
proof (rule adjoint_eqI[symmetric])
  have [simp]: clinear (cinner (swap_ell2 *V x)) for x :: ('a × 'b) ell2
    by (metis (no_types, lifting) cblinfun.add_right cinner_scaleC_right clinearI complex_scaleC_def mult.comm_neutral of_complex_def vector_to_cblinfun_adj_apply)
  have [simp]: clinear (λa. x, swap_ell2 *V a) for x :: ('a × 'b) ell2
    by (simp add: cblinfun.add_right cinner_add_right clinearI)
  have [simp]: antilinear (λa. a, y) for y :: ('a × 'b) ell2
    using bounded_antilinear_cinner_left bounded_antilinear_def by blast
  have [simp]: antilinear (λa. swap_ell2 *V a, y) for y :: ('b × 'a) ell2
    by (simp add: cblinfun.add_right cinner_add_left antilinearI)
  have swap_ell2 *V (ket x), ket y = ket x, swap_ell2 *V ket y for x :: 'a × 'b and y
    apply (cases x, cases y)
    by (simp flip: tensor_ell2_ket add: swap_ell2_tensor)
  then have swap_ell2 *V (ket x), y = ket x, swap_ell2 *V y for x :: 'a × 'b and y
    by (rule clinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
  then show swap_ell2 *V x, y = x, swap_ell2 *V y for x :: ('a × 'b) ell2 and y
    apply (rule antilinear_equal_ket[THEN fun_cong, rotated 2])
    by simp_all
qed


lemma tensor_ell2_extensionality:
  assumes "(s t. a *V (s s t) = b *V (s s t))"
  shows "a = b"
  apply (rule equal_ket, case_tac x, hypsubst_thin)
  by (simp add: assms flip: tensor_ell2_ket)

lemma assoc_ell2'_assoc_ell2[simp]: assoc_ell2' oCL assoc_ell2 = id_cblinfun
  by (auto intro!: equal_ket simp: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor simp flip: tensor_ell2_ket)

lemma assoc_ell2_assoc_ell2'[simp]: assoc_ell2 oCL assoc_ell2' = id_cblinfun
  by (auto intro!: equal_ket simp: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor simp flip: tensor_ell2_ket)

lemma unitary_assoc_ell2[simp]: "unitary assoc_ell2"
  unfolding unitary_def by auto

lemma unitary_assoc_ell2'[simp]: "unitary assoc_ell2'"
  unfolding unitary_def by auto

lemma tensor_op_left_add: (x + y) o b = x o b + y o b
  for x y :: 'a::finite ell2 CL 'c::finite ell2 and b :: 'b::finite ell2 CL 'd::finite ell2
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (simp add: plus_cblinfun.rep_eq tensor_ell2_add1 tensor_op_ket)

lemma tensor_op_right_add: b o (x + y) = b o x + b o y
  for x y :: 'a::finite ell2 CL 'c::finite ell2 and b :: 'b::finite ell2 CL 'd::finite ell2
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (simp add: plus_cblinfun.rep_eq tensor_ell2_add2 tensor_op_ket)

lemma tensor_op_scaleC_left: (c *C x) o b = c *C (x o b)
  for x :: 'a::finite ell2 CL 'c::finite ell2 and b :: 'b::finite ell2 CL 'd::finite ell2
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (metis scaleC_cblinfun.rep_eq tensor_ell2_ket tensor_ell2_scaleC1 tensor_op_ell2)

lemma tensor_op_scaleC_right: b o (c *C x) = c *C (b o x)
  for x :: 'a::finite ell2 CL 'c::finite ell2 and b :: 'b::finite ell2 CL 'd::finite ell2
  apply (auto intro!: equal_ket simp: tensor_op_ket)
  by (metis scaleC_cblinfun.rep_eq tensor_ell2_ket tensor_ell2_scaleC2 tensor_op_ell2)

lemma clinear_tensor_left[simp]: clinear (λa. a o b :: _::finite ell2 CL _::finite ell2)
  apply (rule clinearI)
   apply (rule tensor_op_left_add)
  by (rule tensor_op_scaleC_left)

lemma clinear_tensor_right[simp]: clinear (λb. a o b :: _::finite ell2 CL _::finite ell2)
  apply (rule clinearI)
   apply (rule tensor_op_right_add)
  by (rule tensor_op_scaleC_right)

lemma tensor_ell2_nonzero: a s b  0 if a  0 and b  0
  apply (use that in transfer)
  apply auto
  by (metis mult_eq_0_iff old.prod.case)

lemma tensor_op_nonzero:
  fixes a :: 'a::finite ell2 CL 'c::finite ell2 and b :: 'b::finite ell2 CL 'd::finite ell2
  assumes a  0 and b  0
  shows a o b  0
proof -
  from a  0 obtain i where i: a *V ket i  0
    by (metis cblinfun.zero_left equal_ket)
  from b  0 obtain j where j: b *V ket j  0
    by (metis cblinfun.zero_left equal_ket)
  from i j have ijneq0: (a *V ket i) s (b *V ket j)  0
    by (simp add: tensor_ell2_nonzero)
  have (a *V ket i) s (b *V ket j) = (a o b) *V ket (i,j)
    by (simp add: tensor_op_ket)
  with ijneq0 show a o b  0
    by force
qed

lemma inj_tensor_ell2_left: inj (λa::'a::finite ell2. a s b) if b  0 for b :: 'b::finite ell2
proof (rule injI, rule ccontr)
  fix x y :: 'a ell2
  assume eq: x s b = y s b
  assume neq: x  y
  define a where a = x - y
  from neq a_def have neq0: a  0
    by auto
  with b  0 have a s b  0
    by (simp add: tensor_ell2_nonzero)
  then have x s b  y s b
    unfolding a_def
    by (metis add_cancel_left_left diff_add_cancel tensor_ell2_add1)
  with eq show False
    by auto
qed

lemma inj_tensor_ell2_right: inj (λb::'b::finite ell2. a s b) if a  0 for a :: 'a::finite ell2
proof (rule injI, rule ccontr)
  fix x y :: 'b ell2
  assume eq: a s x = a s y
  assume neq: x  y
  define b where b = x - y
  from neq b_def have neq0: b  0
    by auto
  with a  0 have a s b  0
    by (simp add: tensor_ell2_nonzero)
  then have a s x  a s y
    unfolding b_def
    by (metis add_cancel_left_left diff_add_cancel tensor_ell2_add2)
  with eq show False
    by auto
qed



lemma inj_tensor_left: inj (λa::'a::finite ell2 CL 'c::finite ell2. a o b) if b  0 for b :: 'b::finite ell2 CL 'd::finite ell2
proof (rule injI, rule ccontr)
  fix x y :: 'a ell2 CL 'c ell2
  assume eq: x o b = y o b
  assume neq: x  y
  define a where a = x - y
  from neq a_def have neq0: a  0
    by auto
  with b  0 have a o b  0
    by (simp add: tensor_op_nonzero)
  then have x o b  y o b
    unfolding a_def
    by (metis add_cancel_left_left diff_add_cancel tensor_op_left_add) 
  with eq show False
    by auto
qed

lemma inj_tensor_right: inj (λb::'b::finite ell2 CL 'c::finite ell2. a o b) if a  0 for a :: 'a::finite ell2 CL 'd::finite ell2
proof (rule injI, rule ccontr)
  fix x y :: 'b ell2 CL 'c ell2
  assume eq: a o x = a o y
  assume neq: x  y
  define b where b = x - y
  from neq b_def have neq0: b  0
    by auto
  with a  0 have a o b  0
    by (simp add: tensor_op_nonzero)
  then have a o x  a o y
    unfolding b_def
    by (metis add_cancel_left_left diff_add_cancel tensor_op_right_add) 
  with eq show False
    by auto
qed

lemma tensor_ell2_almost_injective:
  assumes tensor_ell2 a b = tensor_ell2 c d
  assumes a  0
  shows γ. b = γ *C d
proof -
  from a  0 obtain i where i: cinner (ket i) a  0
    by (metis cinner_eq_zero_iff cinner_ket_left ell2_pointwise_ortho)
  have cinner (ket i s ket j) (a s b) = cinner (ket i s ket j) (c s d) for j
    using assms by simp
  then have eq2: (cinner (ket i) a) * (cinner (ket j) b) = (cinner (ket i) c) * (cinner (ket j) d) for j
    by (metis tensor_ell2_inner_prod)
  then obtain γ where cinner (ket i) c = γ * cinner (ket i) a
    by (metis i eq_divide_eq)
  with eq2 have (cinner (ket i) a) * (cinner (ket j) b) = (cinner (ket i) a) * (γ * cinner (ket j) d) for j
    by simp
  then have cinner (ket j) b = cinner (ket j) (γ *C d) for j
    using i by force
  then have b = γ *C d
    by (simp add: cinner_ket_eqI)
  then show ?thesis
    by auto
qed


lemma tensor_op_almost_injective:
  fixes a c :: 'a::finite ell2 CL 'b::finite ell2
    and b d :: 'c::finite ell2 CL 'd::finite ell2
  assumes tensor_op a b = tensor_op c d
  assumes a  0
  shows γ. b = γ *C d
proof (cases d = 0)
  case False
  from a  0 obtain ψ where ψ: a *V ψ  0
    by (metis cblinfun.zero_left cblinfun_eqI)
  have (a o b) (ψ s φ) = (c o d) (ψ s φ) for φ
    using assms by simp
  then have eq2: (a ψ) s (b φ) = (c ψ) s (d φ) for φ
    by (simp add: tensor_op_ell2)
  then have eq2': (d φ) s (c ψ) = (b φ) s (a ψ) for φ
    by (metis swap_ell2_tensor)
  from False obtain φ0 where φ0: d φ0  0
    by (metis cblinfun.zero_left cblinfun_eqI)
  obtain γ where c ψ = γ *C a ψ
    apply atomize_elim
    using eq2' φ0 by (rule tensor_ell2_almost_injective)
  with eq2 have (a ψ) s (b φ) = (a ψ) s (γ *C d φ) for φ
    by (simp add: tensor_ell2_scaleC1 tensor_ell2_scaleC2)
  then have b φ = γ *C d φ for φ
    by (smt (verit, best) ψ complex_vector.scale_cancel_right tensor_ell2_almost_injective tensor_ell2_nonzero tensor_ell2_scaleC2)
  then have b = γ *C d
    by (simp add: cblinfun_eqI)
  then show ?thesis
    by auto
next
  case True
  then have c o d = 0
    by (metis add_cancel_right_left tensor_op_right_add)
  then have a o b = 0
    using assms(1) by presburger
  with a  0 have b = 0
    by (meson tensor_op_nonzero)
  then show ?thesis
    by auto
qed


lemma tensor_ell2_0_left[simp]: tensor_ell2 0 x = 0
  apply transfer by auto

lemma tensor_ell2_0_right[simp]: tensor_ell2 x 0 = 0
  apply transfer by auto

lemma tensor_op_0_left[simp]: tensor_op 0 x = (0 :: ('a::finite*'b::finite) ell2 CL ('c::finite*'d::finite) ell2)
  apply (rule equal_ket)
  by (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)

lemma tensor_op_0_right[simp]: tensor_op x 0 = (0 :: ('a::finite*'b::finite) ell2 CL ('c::finite*'d::finite) ell2)
  apply (rule equal_ket)
  by (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)

lemma bij_tensor_ell2_one_dim_left:
  assumes ψ  0
  shows bij (λx::'b::finite ell2. (ψ :: 'a::CARD_1 ell2) s x)
proof (rule bijI)
  show inj (λx::'b::finite ell2. (ψ :: 'a::CARD_1 ell2) s x)
    using assms by (rule inj_tensor_ell2_right)
  have x. ψ s x = φ for φ :: ('a*'b) ell2
  proof (use assms in transfer)
    fix ψ :: 'a  complex and φ :: 'a*'b  complex
    assume has_ell2_norm φ and ψ  (λ_. 0)
    define c where c = ψ undefined
    then have ψ a = c for a 
      apply (subst everything_the_same[of _ undefined])
      by simp
    with ψ  (λ_. 0) have c  0
      by auto

    define x where x j = φ (undefined, j) / c for j
    have (λ(i, j). ψ i * x j) = φ
      apply (auto intro!: ext simp: x_def ψ _ = c c  0)
      apply (subst (2) everything_the_same[of _ undefined])
      by simp
    then show xCollect has_ell2_norm. (λ(i, j). ψ i * x j) = φ
      apply (rule bexI[where x=x])
      by simp
  qed

  then show surj (λx::'b::finite ell2. (ψ :: 'a::CARD_1 ell2) s x)
    by (metis surj_def)
qed

lemma bij_tensor_op_one_dim_left:
  assumes a  0
  shows bij (λx::'c::finite ell2 CL 'd::finite ell2. (a :: 'a::{CARD_1,enum} ell2 CL 'b::{CARD_1,enum} ell2) o x)
proof (rule bijI)
  define t where t = (λx::'c ell2 CL 'd ell2. (a :: 'a ell2 CL 'b ell2) o x)
  define i where
    i = tensor_lift (λ(x::'a ell2 CL 'b ell2) (y::'c ell2 CL 'd ell2). (one_dim_iso x / one_dim_iso a) *C y)

  have [simp]: clinear i
    by (auto intro!: tensor_lift_clinear simp: i_def cbilinear_def clinearI scaleC_add_left add_divide_distrib)
  have [simp]: clinear t
    by (simp add: t_def)
  have i (x o y) = (one_dim_iso x / one_dim_iso a) *C y for x y
    by (auto intro!: clinearI tensor_lift_correct[THEN fun_cong, THEN fun_cong] simp: t_def i_def cbilinear_def  scaleC_add_left add_divide_distrib)
  then have t (i (x o y)) = x o y for x y
    apply (simp add: t_def)
    by (smt (z3) assms complex_vector.scale_eq_0_iff nonzero_mult_div_cancel_right one_dim_scaleC_1 scaleC_scaleC tensor_op_scaleC_left tensor_op_scaleC_right times_divide_eq_left)
  then have t (i x) = x for x
    apply (rule_tac fun_cong[where x=x])
    apply (rule tensor_extensionality)
    by (auto intro: clinear_compose complex_vector.module_hom_ident simp flip: o_def[of t i])
  then show surj t 
    by (rule surjI)

  show inj t
    unfolding t_def using assms by (rule inj_tensor_right)
qed

lemma swap_ell2_selfinv[simp]: swap_ell2 oCL swap_ell2 = id_cblinfun
  apply (rule tensor_ell2_extensionality)
  by auto

lemma bij_tensor_op_one_dim_right:
  assumes b  0
  shows bij (λx::'c::finite ell2 CL 'd::finite ell2. x o (b :: 'a::{CARD_1,enum} ell2 CL 'b::{CARD_1,enum} ell2))
    (is bij ?f)
proof -
  let ?sf = (λx. swap_ell2 oCL (?f x) oCL swap_ell2)
  let ?s = (λx. swap_ell2 oCL x oCL swap_ell2)
  let ?g = (λx::'c::finite ell2 CL 'd::finite ell2. (b :: 'a::{CARD_1,enum} ell2 CL 'b::{CARD_1,enum} ell2) o x)
  have ?sf = ?g
    by (auto intro!: ext tensor_ell2_extensionality simp add: swap_ell2_tensor tensor_op_ell2)
  have bij ?g
    using assms by (rule bij_tensor_op_one_dim_left)
  have ?s o ?sf = ?f
    apply (auto intro!: ext simp: cblinfun_assoc_left)
    by (auto simp: cblinfun_assoc_right)
  also have bij ?s
    apply (rule o_bij[where g=(λx. swap_ell2 oCL x oCL swap_ell2)])
     apply (auto intro!: ext simp: cblinfun_assoc_left)
    by (auto simp: cblinfun_assoc_right)
  show bij ?f
    apply (subst ?s o ?sf = ?f[symmetric], subst ?sf = ?g)
    using bij ?g bij ?s by (rule bij_comp)
qed

lemma overlapping_tensor:
  fixes a23 :: ('a2::finite*'a3::finite) ell2 CL ('b2::finite*'b3::finite) ell2
    and b12 :: ('a1::finite*'a2) ell2 CL ('b1::finite*'b2) ell2
  assumes eq: butterfly ψ ψ' o a23 = assoc_ell2 oCL (b12 o butterfly φ φ') oCL assoc_ell2'
  assumes ψ  0 ψ'  0 φ  0 φ'  0
  shows c. butterfly ψ ψ' o a23 = butterfly ψ ψ' o c o butterfly φ φ'
proof -
  note [[show_types]]
  let ?id1 = id_cblinfun :: unit ell2 CL unit ell2
  note id_cblinfun_eq_1[simp del]
  define d where d = butterfly ψ ψ' o a23

  define ψn ψn' a23n where ψn = ψ /C norm ψ and ψn' = ψ' /C norm ψ' and a23n = norm ψ *C norm ψ' *C a23
  have [simp]: norm ψn = 1 norm ψn' = 1
    using ψ  0 ψ'  0 by (auto simp: ψn_def ψn'_def norm_inverse)
  have n1: butterfly ψn ψn' o a23n = butterfly ψ ψ' o a23
    apply (auto simp: ψn_def ψn'_def a23n_def tensor_op_scaleC_left tensor_op_scaleC_right)
    by (metis (no_types, lifting) assms(2) assms(3) inverse_mult_distrib mult.commute no_zero_divisors norm_eq_zero of_real_eq_0_iff right_inverse scaleC_one)

  define φn φn' b12n where φn = φ /C norm φ and φn' = φ' /C norm φ' and b12n = norm φ *C norm φ' *C b12
  have [simp]: norm φn = 1 norm φn' = 1
    using φ  0 φ'  0 by (auto simp: φn_def φn'_def norm_inverse)
  have n2: b12n o butterfly φn φn' = b12 o butterfly φ φ'
    apply (auto simp: φn_def φn'_def b12n_def tensor_op_scaleC_left tensor_op_scaleC_right)
    by (metis (no_types, lifting) assms(4) assms(5) field_class.field_inverse inverse_mult_distrib mult.commute no_zero_divisors norm_eq_zero of_real_hom.hom_0 scaleC_one)

  define c' :: (unit*'a2*unit) ell2 CL (unit*'b2*unit) ell2 
    where c' = (vector_to_cblinfun ψn o id_cblinfun o vector_to_cblinfun φn)* oCL d
            oCL (vector_to_cblinfun ψn' o id_cblinfun o vector_to_cblinfun φn')

  define c'' :: 'a2 ell2 CL 'b2 ell2
    where c'' = inv (λc''. id_cblinfun o c'' o id_cblinfun) c'

  have *: bij (λc''::'a2 ell2 CL 'b2 ell2. ?id1 o c'' o ?id1)
    apply (subst asm_rl[of _ = (λx. id_cblinfun o x) o (λc''. c'' o id_cblinfun)])
    using [[show_consts]]
    by (auto intro!: bij_comp bij_tensor_op_one_dim_left bij_tensor_op_one_dim_right)

  have c'_c'': c' = ?id1 o c'' o ?id1
    unfolding c''_def 
    apply (rule surj_f_inv_f[where y=c', symmetric])
    using * by (rule bij_is_surj)

  define c :: 'a2 ell2 CL 'b2 ell2
    where c = c'' /C norm ψ /C norm ψ' /C norm φ /C norm φ'

  have aux: assoc_ell2' oCL (assoc_ell2 oCL x oCL assoc_ell2') oCL assoc_ell2 = x for x
    apply (simp add: cblinfun_assoc_left)
    by (simp add: cblinfun_assoc_right)
  have aux2: (assoc_ell2 oCL ((x o y) o z) oCL assoc_ell2') = x o (y o z) for x y z
    apply (rule equal_ket, rename_tac xyz)
    apply (case_tac xyz, hypsubst_thin)
    by (simp flip: tensor_ell2_ket add: assoc_ell2'_tensor assoc_ell2_tensor tensor_op_ell2)

  have d = (butterfly ψn ψn o id_cblinfun) oCL d oCL (butterfly ψn' ψn' o id_cblinfun)
    by (auto simp: d_def n1[symmetric] comp_tensor_op cnorm_eq_1[THEN iffD1])
  also have  = (butterfly ψn ψn o id_cblinfun) oCL assoc_ell2 oCL (b12n o butterfly φn φn')
                  oCL assoc_ell2' oCL (butterfly ψn' ψn' o id_cblinfun)
    by (auto simp: d_def eq n2 cblinfun_assoc_left)
  also have  = (butterfly ψn ψn o id_cblinfun) oCL assoc_ell2 oCL 
               ((id_cblinfun o butterfly φn φn) oCL (b12n o butterfly φn φn') oCL (id_cblinfun o butterfly φn' φn'))
               oCL assoc_ell2' oCL (butterfly ψn' ψn' o id_cblinfun)
    by (auto simp: comp_tensor_op cnorm_eq_1[THEN iffD1])
  also have  = (butterfly ψn ψn o id_cblinfun) oCL assoc_ell2 oCL 
               ((id_cblinfun o butterfly φn φn) oCL (assoc_ell2' oCL d oCL assoc_ell2) oCL (id_cblinfun o butterfly φn' φn'))
               oCL assoc_ell2' oCL (butterfly ψn' ψn' o id_cblinfun)
    by (auto simp: d_def n2 eq aux)
  also have  = ((butterfly ψn ψn o id_cblinfun) oCL (assoc_ell2 oCL (id_cblinfun o butterfly φn φn) oCL assoc_ell2'))
               oCL d oCL ((assoc_ell2 oCL (id_cblinfun o butterfly φn' φn') oCL assoc_ell2') oCL (butterfly ψn' ψn' o id_cblinfun))
    by (auto simp: sandwich_def cblinfun_assoc_left)
  also have  = (butterfly ψn ψn o id_cblinfun o butterfly φn φn)
               oCL d oCL (butterfly ψn' ψn' o id_cblinfun o butterfly φn' φn')
    apply (simp only: tensor_id[symmetric] comp_tensor_op aux2)
    by (simp add: cnorm_eq_1[THEN iffD1])
  also have  = (vector_to_cblinfun ψn o id_cblinfun o vector_to_cblinfun φn)
               oCL c' oCL (vector_to_cblinfun ψn' o id_cblinfun o vector_to_cblinfun φn')*
    apply (simp add: c'_def butterfly_def_one_dim[where 'c="unit ell2"] cblinfun_assoc_left comp_tensor_op
                      tensor_op_adjoint cnorm_eq_1[THEN iffD1])
    by (simp add: cblinfun_assoc_right comp_tensor_op)
  also have  = butterfly ψn ψn' o c'' o butterfly φn φn'
    by (simp add: c'_c'' comp_tensor_op tensor_op_adjoint butterfly_def_one_dim[symmetric])
  also have  = butterfly ψ ψ' o c o butterfly φ φ'
    by (simp add: ψn_def ψn'_def φn_def φn'_def c_def tensor_op_scaleC_left tensor_op_scaleC_right)
  finally have d_c: d = butterfly ψ ψ' o c o butterfly φ φ'
    by -
  then show ?thesis
    by (auto simp: d_def)
qed

lemma norm_tensor_ell2: norm (a s b) = norm a * norm b
  apply transfer
  by (simp add: ell2_norm_finite sum_product sum.cartesian_product case_prod_beta
      norm_mult power_mult_distrib flip: real_sqrt_mult)

lemma bounded_cbilinear_tensor_ell2[bounded_cbilinear]: bounded_cbilinear (⊗s)
proof standard
  fix a a' :: "'a ell2" and b b' :: "'b ell2" and r :: complex
  show tensor_ell2 (a + a') b = tensor_ell2 a b + tensor_ell2 a' b
    by (meson tensor_ell2_add1)
  show tensor_ell2 a (b + b') = tensor_ell2 a b + tensor_ell2 a b'
    by (simp add: tensor_ell2_add2)  
  show tensor_ell2 (r *C a) b = r *C tensor_ell2 a b
    by (simp add: tensor_ell2_scaleC1)
  show tensor_ell2 a (r *C b) = r *C tensor_ell2 a b
    by (simp add: tensor_ell2_scaleC2)
  show K. a b. norm (tensor_ell2 a b)  norm a * norm b * K 
    apply (rule exI[of _ 1])
    by (simp add: norm_tensor_ell2)
qed


end

Theory Axioms_Quantum

section Quantum instantiation of registers

(* AXIOM INSTANTIATION (use instantiate_laws.py to generate Laws_Quantum.thy)

    # Type classes
    domain → finite

    # Types
    some_domain → unit

    # Constants
    comp_update → cblinfun_compose
    id_update → id_cblinfun
    preregister → clinear
    tensor_update → tensor_op
    
    # Lemmas
    id_update_left → cblinfun_compose_id_left
    id_update_right → cblinfun_compose_id_right
    comp_update_assoc → cblinfun_compose_assoc
    id_preregister → complex_vector.linear_id
    comp_preregister → clinear_compose
    tensor_update_mult → comp_tensor_op
    # preregister_tensor_left → clinear_tensor_right
    # preregister_tensor_right → clinear_tensor_left

    # Chapter name
    Generic laws about registers → Generic laws about registers, instantiated quantumly
    Generic laws about complements → Generic laws about complements, instantiated quantumly
*)

theory Axioms_Quantum
  imports Jordan_Normal_Form.Matrix_Impl "HOL-Library.Rewrite"
          Complex_Bounded_Operators.Complex_L2
          Finite_Tensor_Product
begin


unbundle cblinfun_notation
no_notation m_inv ("invı _" [81] 80)

type_synonym 'a update = ('a ell2, 'a ell2) cblinfun

lemma preregister_mult_right: clinear (λa. a oCL z)
  by (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
lemma preregister_mult_left: clinear (λa. z oCL a)
  by (meson cbilinear_cblinfun_compose cbilinear_def)

definition register :: ('a::finite update  'b::finite update)  bool where
  "register F  
     clinear F
    F id_cblinfun = id_cblinfun 
    (a b. F(a oCL b) = F a oCL F b)
    (a. F (a*) = (F a)*)"

lemma register_of_id: register F  F id_cblinfun = id_cblinfun
  by (simp add: register_def)

lemma register_id: register id
  by (simp add: register_def complex_vector.module_hom_id)

lemma register_preregister: "register F  clinear F"
  unfolding register_def by simp

lemma register_comp: "register F  register G  register (G  F)"
  unfolding register_def
  apply auto
  using clinear_compose by blast

lemma register_mult: "register F  cblinfun_compose (F a) (F b) = F (cblinfun_compose a b)"
  unfolding register_def
  by auto

lemma register_tensor_left: register (λa. tensor_op a id_cblinfun)
  by (simp add: comp_tensor_op register_def tensor_op_cbilinear tensor_op_adjoint)

lemma register_tensor_right: register (λa. tensor_op id_cblinfun a)
  by (simp add: comp_tensor_op register_def tensor_op_cbilinear tensor_op_adjoint)


definition register_pair ::
  ('a::finite update  'c::finite update)  ('b::finite update  'c update)
          (('a×'b) update  'c update) where
  register_pair F G = tensor_lift (λa b. F a oCL G b)

lemma cbilinear_F_comp_G[simp]: clinear F  clinear G  cbilinear (λa b. F a oCL G b)
  unfolding cbilinear_def
  by (auto simp add: clinear_iff bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right)

lemma register_pair_apply: 
  assumes register F and register G
  assumes a b. F a oCL G b = G b oCL F a
  shows (register_pair F G) (tensor_op a b) = F a oCL G b
  unfolding register_pair_def
  apply (subst tensor_lift_correct[THEN fun_cong, THEN fun_cong])
   apply (rule cbilinear_F_comp_G)
  using assms apply (auto intro!: cbilinear_F_comp_G)
  using register_def by auto

lemma register_pair_is_register:
  fixes F :: 'a::finite update  'c::finite update and G
  assumes [simp]: register F and [simp]: register G
  assumes a b. F a oCL G b = G b oCL F a
  shows register (register_pair F G) 
proof (unfold register_def, intro conjI allI)
  have [simp]: clinear F clinear G
    using assms register_def by blast+
  have [simp]: F id_cblinfun = id_cblinfun G id_cblinfun = id_cblinfun
    using assms(1,2) register_def by blast+
  show [simp]: clinear (register_pair F G)
    unfolding register_pair_def apply (rule tensor_lift_clinear)
    by simp
  show register_pair F G id_cblinfun = id_cblinfun
    apply (simp flip: tensor_id)
    apply (subst register_pair_apply)
    using assms by simp_all
  have [simp]: clinear (λy. register_pair F G (x oCL y)) for x :: ('a×'b) update
    apply (rule clinear_compose[unfolded o_def, where g=register_pair F G])
    by (simp_all add: preregister_mult_left bounded_cbilinear.add_right clinearI)
  have [simp]: clinear (λy. x oCL register_pair F G y) for x :: 'c update
    apply (rule clinear_compose[unfolded o_def, where f=register_pair F G])
    by (simp_all add: preregister_mult_left bounded_cbilinear.add_right clinearI)
  have [simp]: clinear (λx. register_pair F G (x oCL y)) for y :: ('a×'b) update
    apply (rule clinear_compose[unfolded o_def, where g=register_pair F G])
    by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
  have [simp]: clinear (λx. register_pair F G x oCL y) for y :: 'c update
    apply (rule clinear_compose[unfolded o_def, where f=register_pair F G])
    by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
  have [simp]: F (x oCL y) = F x oCL F y for x y
    by (simp add: register_mult)
  have [simp]: G (x oCL y) = G x oCL G y for x y
    by (simp add: register_mult)
  have [simp]: clinear (λa. (register_pair F G (a*))*)
    apply (rule antilinear_o_antilinear[unfolded o_def, where f=adj])
     apply simp
    apply (rule antilinear_o_clinear[unfolded o_def, where g=adj])
    by (simp_all)
  have [simp]: F (a*) = (F a)* for a
    using assms(1) register_def by blast
  have [simp]: G (b*) = (G b)* for b
    using assms(2) register_def by blast

  fix a b
  show register_pair F G (a oCL b) = register_pair F G a oCL register_pair F G b
    apply (rule tensor_extensionality[THEN fun_cong, where x=b], simp_all)
    apply (rule tensor_extensionality[THEN fun_cong, where x=a], simp_all)
    apply (simp_all add: comp_tensor_op register_pair_apply assms(3))
    using assms(3)
    by (metis cblinfun_compose_assoc)
  have (register_pair F G (a*))* = register_pair F G a
    apply (rule tensor_extensionality[THEN fun_cong, where x=a])
    by (simp_all add: tensor_op_adjoint register_pair_apply assms(3))
  then show register_pair F G (a*) = register_pair F G a*
    by (metis double_adj)
qed

end

Theory Laws_Quantum

(*
 * This is an autogenerated file. Do not edit.
 * The original is Laws.thy. It was converted using instantiate_laws.py.
 *)

section Generic laws about registers, instantiated quantumly

theory Laws_Quantum
  imports Axioms_Quantum
begin

text This notation is only used inside this file
notation cblinfun_compose (infixl "*u" 55)
notation tensor_op (infixr "u" 70)
notation register_pair ("'(_;_')")

subsection Elementary facts

declare complex_vector.linear_id[simp]
declare cblinfun_compose_id_left[simp]
declare cblinfun_compose_id_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]

subsection Preregisters

lemma preregister_tensor_left[simp]: clinear (λb::'b::finite update. tensor_op a b)
  for a :: 'a::finite update
proof -
  have clinear ((λb1::('a×'b) update. (a u id_cblinfun) *u b1) o (λb. tensor_op id_cblinfun b))
    by (rule clinear_compose; simp)
  then show ?thesis
    by (simp add: o_def comp_tensor_op)
qed

lemma preregister_tensor_right[simp]: clinear (λa::'a::finite update. tensor_op a b)  
  for b :: 'b::finite update
proof -
  have clinear ((λa1::('a×'b) update. (id_cblinfun u b) *u a1) o (λa. tensor_op a id_cblinfun))
    by (rule clinear_compose, simp_all)
  then show ?thesis
    by (simp add: o_def comp_tensor_op)
qed

subsection Registers

lemma id_update_tensor_register[simp]:
  assumes register F
  shows register (λa::'a::finite update. id_cblinfun u F a)
  using assms apply (rule register_comp[unfolded o_def])
  by simp

lemma register_tensor_id_update[simp]:
  assumes register F
  shows register (λa::'a::finite update. F a u id_cblinfun)
  using assms apply (rule register_comp[unfolded o_def])
  by simp

subsection Tensor product of registers

definition register_tensor  (infixr "r" 70) where
  "register_tensor F G = register_pair (λa. tensor_op (F a) id_cblinfun) (λb. tensor_op id_cblinfun (G b))"

lemma register_tensor_is_register: 
  fixes F :: "'a::finite update  'b::finite update" and G :: "'c::finite update  'd::finite update"
  shows "register F  register G  register (F r G)"
  unfolding register_tensor_def
  apply (rule register_pair_is_register)
  by (simp_all add: comp_tensor_op)

lemma register_tensor_apply[simp]:
  fixes F :: "'a::finite update  'b::finite update" and G :: "'c::finite update  'd::finite update"
  assumes register F and register G
  shows "(F r G) (a u b) = F a u G b"
  unfolding register_tensor_def
  apply (subst register_pair_apply)
  unfolding register_tensor_def 
  by (simp_all add: assms comp_tensor_op)

definition "separating (_::'b::finite itself) A  
  (F G :: 'a::finite update  'b update. clinear F  clinear G  (xA. F x = G x)  F = G)"

lemma separating_UNIV[simp]: separating TYPE(_) UNIV
  unfolding separating_def by auto

lemma separating_mono: A  B  separating TYPE('a::finite) A  separating TYPE('a) B
  unfolding separating_def by (meson in_mono) 

lemma register_eqI: separating TYPE('b::finite) A  clinear F  clinear G  (x. xA  F x = G x)  F = (G::_  'b update)
  unfolding separating_def by auto

lemma separating_tensor:
  fixes A :: 'a::finite update set and B :: 'b::finite update set
  assumes [simp]: separating TYPE('c::finite) A
  assumes [simp]: separating TYPE('c) B
  shows separating TYPE('c) {a u b | a b. aA  bB}
proof (unfold separating_def, intro allI impI)
  fix F G :: ('a×'b) update  'c update
  assume [simp]: clinear F clinear G
  have [simp]: clinear (λx. F (a u x)) for a
    using _ clinear F apply (rule clinear_compose[unfolded o_def])
    by simp
  have [simp]: clinear (λx. G (a u x)) for a
    using _ clinear G apply (rule clinear_compose[unfolded o_def])
    by simp
  have [simp]: clinear (λx. F (x u b)) for b
    using _ clinear F apply (rule clinear_compose[unfolded o_def])
    by simp
  have [simp]: clinear (λx. G (x u b)) for b
    using _ clinear G apply (rule clinear_compose[unfolded o_def])
    by simp

  assume x{a u b |a b. aA  bB}. F x = G x
  then have EQ: F (a u b) = G (a u b) if a  A and b  B for a b
    using that by auto
  then have F (a u b) = G (a u b) if a  A for a b
    apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
    using that by auto
  then have F (a u b) = G (a u b) for a b
    apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
    by auto
  then show "F = G"
    apply (rule tensor_extensionality[rotated -1])
    by auto
qed

lemma register_tensor_distrib:
  assumes [simp]: register F register G register H register L
  shows (F r G) o (H r L) = (F o H) r (G o L)
  apply (rule tensor_extensionality)
  by (auto intro!: register_comp register_preregister register_tensor_is_register)

text The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}
lemma separating_tensor':
  fixes A :: 'a::finite update set and B :: 'b::finite update set
  assumes separating TYPE('c::finite) A
  assumes separating TYPE('c) B
  assumes C = {a u b | a b. aA  bB}
  shows separating TYPE('c) C
  using assms
  by (simp add: separating_tensor)

lemma tensor_extensionality3: 
  fixes F G :: ('a::finite×'b::finite×'c::finite) update  'd::finite update
  assumes [simp]: register F register G
  assumes "f g h. F (f u g u h) = G (f u g u h)"
  shows "F = G"
proof (rule register_eqI[where A={aubuc| a b c. True}])
  have separating TYPE('d) {b u c |b c. True}
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show separating TYPE('d) {a u b u c |a b c. True}
    apply (rule_tac separating_tensor'[where A=UNIV and B={buc| b c. True}])
    by auto
  show clinear F clinear G by auto
  show x  {a u b u c |a b c. True}  F x = G x for x
    using assms(3) by auto
qed

lemma tensor_extensionality3': 
  fixes F G :: (('a::finite×'b::finite)×'c::finite) update  'd::finite update
  assumes [simp]: register F register G
  assumes "f g h. F ((f u g) u h) = G ((f u g) u h)"
  shows "F = G"
proof (rule register_eqI[where A={(aub)uc| a b c. True}])
  have separating TYPE('d) {a u b | a b. True}
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show separating TYPE('d) {(a u b) u c |a b c. True}
    apply (rule_tac separating_tensor'[where B=UNIV and A={aub| a b. True}])
    by auto
  show clinear F clinear G by auto
  show x  {(a u b) u c |a b c. True}  F x = G x for x
    using assms(3) by auto
qed

lemma register_tensor_id[simp]: id r id = id
  apply (rule tensor_extensionality)
  by (auto simp add: register_tensor_is_register)

subsection Pairs and compatibility

definition compatible :: ('a::finite update  'c::finite update)
                        ('b::finite update  'c update)  bool where
  compatible F G  register F  register G  (a b. F a *u G b = G b *u F a)

lemma compatibleI:
  assumes "register F" and "register G"
  assumes a b. (F a) *u (G b) = (G b) *u (F a)
  shows "compatible F G"
  using assms unfolding compatible_def by simp

lemma swap_registers:
  assumes "compatible R S"
  shows "R a *u S b = S b *u R a"
  using assms unfolding compatible_def by metis

lemma compatible_sym: "compatible x y  compatible y x"
  by (simp add: compatible_def)

lemma pair_is_register[simp]:
  assumes "compatible F G"
  shows "register (F; G)"
  by (metis assms compatible_def register_pair_is_register)

lemma register_pair_apply:
  assumes compatible F G
  shows (F; G) (a u b) = (F a) *u (G b)
  apply (rule register_pair_apply)
  using assms unfolding compatible_def by metis+

lemma register_pair_apply':
  assumes compatible F G
  shows (F; G) (a u b) = (G b) *u (F a)
  apply (subst register_pair_apply)
  using assms by (auto simp: compatible_def intro: register_preregister)



lemma compatible_comp_left[simp]: "compatible F G  register H  compatible (F  H) G"
  by (simp add: compatible_def)

lemma compatible_comp_right[simp]: "compatible F G  register H  compatible F (G  H)"
  by (simp add: compatible_def)

lemma compatible_comp_inner[simp]: 
  "compatible F G  register H  compatible (H  F) (H  G)"
  by (smt (verit, best) comp_apply compatible_def register_comp register_mult)

lemma compatible_register1: compatible F G  register F
  by (simp add: compatible_def)
lemma compatible_register2: compatible F G  register G
  by (simp add: compatible_def)

lemma pair_o_tensor:
  assumes "compatible A B" and [simp]: register C and [simp]: register D
  shows "(A; B) o (C r D) = (A o C; B o D)"
  apply (rule tensor_extensionality)
  using assms by (simp_all add: register_tensor_is_register register_pair_apply clinear_compose)

lemma compatible_tensor_id_update_left[simp]:
  fixes F :: "'a::finite update  'c::finite update" and G :: "'b::finite update  'c::finite update"
  assumes "compatible F G"
  shows "compatible (λa. id_cblinfun u F a) (λa. id_cblinfun u G a)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_right[simp]:
  fixes F :: "'a::finite update  'c::finite update" and G :: "'b::finite update  'c::finite update"
  assumes "compatible F G"
  shows "compatible (λa. F a u id_cblinfun) (λa. G a u id_cblinfun)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_rl[simp]:
  assumes "register F" and "register G"
  shows "compatible (λa. F a u id_cblinfun) (λa. id_cblinfun u G a)"
  apply (rule compatibleI)
  using assms by (auto simp: comp_tensor_op)

lemma compatible_tensor_id_update_lr[simp]:
  assumes "register F" and "register G"
  shows "compatible (λa. id_cblinfun u F a) (λa. G a u id_cblinfun)"
  apply (rule compatibleI)
  using assms by (auto simp: comp_tensor_op)

lemma register_comp_pair:
  assumes [simp]: register F and [simp]: compatible G H
  shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
  show clinear (F  G;F  H) and clinear (F  (G;H))
    by simp_all

  have [simp]: compatible (F o G) (F o H)
    apply (rule compatible_comp_inner, simp)
    by simp
  then have [simp]: register (F  G) register (F  H)
    unfolding compatible_def by auto
  from assms have [simp]: register G register H
    unfolding compatible_def by auto
  fix a b
  show (F  G;F  H) (a u b) = (F  (G;H)) (a u b)
    by (auto simp: register_pair_apply register_mult comp_tensor_op)
qed

lemma swap_registers_left:
  assumes "compatible R S"
  shows "R a *u S b *u c = S b *u R a *u c"
  using assms unfolding compatible_def by metis

lemma swap_registers_right:
  assumes "compatible R S"
  shows "c *u R a *u S b = c *u S b *u R a"
  by (metis assms cblinfun_compose_assoc compatible_def)

lemmas compatible_ac_rules = swap_registers cblinfun_compose_assoc[symmetric] swap_registers_right

subsection Fst and Snd

definition Fst where Fst a = a u id_cblinfun
definition Snd where Snd a = id_cblinfun u a

lemma register_Fst[simp]: register Fst
  unfolding Fst_def by (rule register_tensor_left)

lemma register_Snd[simp]: register Snd
  unfolding Snd_def by (rule register_tensor_right)

lemma compatible_Fst_Snd[simp]: compatible Fst Snd
  apply (rule compatibleI, simp, simp)
  by (simp add: Fst_def Snd_def comp_tensor_op)

lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]

definition swap = (Snd; Fst)

lemma swap_apply[simp]: "swap (a u b) = (b u a)"
  unfolding swap_def
  by (simp add: Axioms_Quantum.register_pair_apply Fst_def Snd_def comp_tensor_op) 

lemma swap_o_Fst: "swap o Fst = Snd"
  by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
  by (auto simp add: Fst_def Snd_def)

lemma register_swap[simp]: register swap
  by (simp add: swap_def)

lemma pair_Fst_Snd: (Fst; Snd) = id
  apply (rule tensor_extensionality)
  by (simp_all add: register_pair_apply Fst_def Snd_def comp_tensor_op)

lemma swap_o_swap[simp]: swap o swap = id
  by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)

lemma swap_swap[simp]: swap (swap x) = x
  by (simp add: pointfree_idE)

lemma inv_swap[simp]: inv swap = swap
  by (meson inv_unique_comp swap_o_swap)

lemma register_pair_Fst:
  assumes compatible F G
  shows (F;G) o Fst = F
  using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)

lemma register_pair_Snd:
  assumes compatible F G
  shows (F;G) o Snd = G
  using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)

lemma register_Fst_register_Snd[simp]:
  assumes register F
  shows (F o Fst; F o Snd) = F
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)

lemma register_Snd_register_Fst[simp]: 
  assumes register F
  shows (F o Snd; F o Fst) = F o swap
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)


lemma compatible3[simp]:
  assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible (F; G) H"
proof (rule compatibleI)
  have [simp]: register F register G register H
    using assms compatible_def by auto
  then have [simp]: clinear F clinear G clinear H
    using register_preregister by blast+
  have [simp]: clinear (λa. (F;G) a *u z) for z
    apply (rule clinear_compose[unfolded o_def, of (F;G)])
    by simp_all
  have [simp]: clinear (λa. z *u (F;G) a) for z
    apply (rule clinear_compose[unfolded o_def, of (F;G)])
    by simp_all
  have "(F; G) (f u g) *u H h = H h *u (F; G) (f u g)" for f g h
  proof -
    have FH: "F f *u H h = H h *u F f"
      using assms compatible_def by metis
    have GH: "G g *u H h = H h *u G g"
      using assms compatible_def by metis
    have (F; G) (f u g) *u (H h) = F f *u G g *u H h
      using compatible F G by (subst register_pair_apply, auto)
    also have  = H h *u F f *u G g
      using FH GH by (metis cblinfun_compose_assoc)
    also have  = H h *u (F; G) (f u g)
      using compatible F G by (subst register_pair_apply, auto simp: cblinfun_compose_assoc)
    finally show ?thesis
      by -
  qed
  then show "(F; G) fg *u (H h) = (H h) *u (F; G) fg" for fg h
    apply (rule_tac tensor_extensionality[THEN fun_cong])
    by auto
  show "register H" and  "register (F; G)"
    by simp_all
qed

lemma compatible3'[simp]:
  assumes "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible F (G; H)"
  apply (rule compatible_sym)
  apply (rule compatible3)
  using assms by (auto simp: compatible_sym)

lemma pair_o_swap[simp]:
  assumes [simp]: "compatible A B"
  shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
  have [simp]: "clinear A" "clinear B"
     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
    by (metis (full_types) assms compatible_register2 register_preregister)
  then show clinear ((A; B)  swap)
    by simp
  show clinear (B; A)
    by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
  show ((A; B)  swap) (a u b) = (B; A) (a u b) for a b
    (* Without the "only:", we would not need the "apply subst",
       but that proof fails when instantiated in Classical.thy *)
    apply (simp only: o_def swap_apply)
    apply (subst register_pair_apply, simp)
    apply (subst register_pair_apply, simp add: compatible_sym)
    by (metis (no_types, lifting) assms compatible_def)
qed


subsection Compatibility of register tensor products

lemma compatible_register_tensor:
  fixes F :: 'a::finite update  'e::finite update and G :: 'b::finite update  'f::finite update
    and F' :: 'c::finite update  'e update and G' :: 'd::finite update  'f update
  assumes [simp]: compatible F F'
  assumes [simp]: compatible G G'
  shows compatible (F r G) (F' r G')
proof -
  note [intro!] = 
    clinear_compose[OF _ preregister_mult_right, unfolded o_def]
    clinear_compose[OF _ preregister_mult_left, unfolded o_def]
    clinear_compose
    register_tensor_is_register
  have [simp]: register F register G register F' register G'
    using assms compatible_def by blast+
  have [simp]: register (F r G) register (F' r G')
    by (auto simp add: register_tensor_def)
  have [simp]: register (F;F') register (G;G')
    by auto
  define reorder :: (('a×'b) × ('c×'d)) update  (('a×'c) × ('b×'d)) update
    where reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))
  have [simp]: clinear reorder
    by (auto simp: reorder_def)
  have [simp]: reorder ((a u b) u (c u d)) = ((a u c) u (b u d)) for a b c d
    apply (simp add: reorder_def register_pair_apply)
    by (simp add: Fst_def Snd_def comp_tensor_op)
  define Φ where Φ c d = ((F;F') r (G;G')) o reorder o (λσ. σ u (c u d)) for c d
  have [simp]: clinear (Φ c d) for c d
    unfolding Φ_def 
    by (auto intro: register_preregister)
  have Φ c d (a u b) = (F r G) (a u b) *u (F' r G') (c u d) for a b c d
    unfolding Φ_def by (auto simp: register_pair_apply comp_tensor_op)
  then have Φ1: Φ c d σ = (F r G) σ *u (F' r G') (c u d) for c d σ
    apply (rule_tac fun_cong[of _ _ σ])
    apply (rule tensor_extensionality)
    by auto
  have Φ c d (a u b) = (F' r G') (c u d) *u (F r G) (a u b) for a b c d
    unfolding Φ_def apply (auto simp: register_pair_apply)
    by (metis assms(1) assms(2) compatible_def comp_tensor_op)
  then have Φ2: Φ c d σ = (F' r G') (c u d) *u (F r G) σ for c d σ
    apply (rule_tac fun_cong[of _ _ σ])
    apply (rule tensor_extensionality)
    by auto
  from Φ1 Φ2 have (F r G) σ *u (F' r G') τ = (F' r G') τ *u (F r G) σ for τ σ
    apply (rule_tac fun_cong[of _ _ τ])
    apply (rule tensor_extensionality)
    by auto
  then show ?thesis
    apply (rule compatibleI[rotated -1])
    by auto
qed

subsection Associativity of the tensor product

definition assoc :: (('a::finite×'b::finite)×'c::finite) update  ('a×('b×'c)) update where 
  assoc = ((Fst; Snd o Fst); Snd o Snd)

lemma assoc_is_hom[simp]: clinear assoc
  by (auto simp: assoc_def)

lemma assoc_apply[simp]: assoc ((a u b) u c) = (a u (b u c))
  by (auto simp: assoc_def register_pair_apply Fst_def Snd_def comp_tensor_op)

definition assoc' :: ('a×('b×'c)) update  (('a::finite×'b::finite)×'c::finite) update where 
  assoc' = (Fst o Fst; (Fst o Snd; Snd))

lemma assoc'_is_hom[simp]: clinear assoc'
  by (auto simp: assoc'_def)

lemma assoc'_apply[simp]: assoc' (a u (b u c)) =  ((a u b) u c)
  by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def comp_tensor_op)

lemma register_assoc[simp]: register assoc
  unfolding assoc_def
  by force

lemma register_assoc'[simp]: register assoc'
  unfolding assoc'_def 
  by force

lemma pair_o_assoc[simp]:
  assumes [simp]: compatible F G compatible G H compatible F H
  shows (F; (G; H))  assoc = ((F; G); H)
proof (rule tensor_extensionality3')
  show register ((F; (G; H))  assoc)
    by simp
  show register ((F; G); H)
    by simp
  show ((F; (G; H))  assoc) ((f u g) u h) = ((F; G); H) ((f u g) u h) for f g h
    by (simp add: register_pair_apply assoc_apply cblinfun_compose_assoc)
qed

lemma pair_o_assoc'[simp]:
  assumes [simp]: compatible F G compatible G H compatible F H
  shows ((F; G); H)  assoc' = (F; (G; H))
proof (rule tensor_extensionality3)
  show register (((F; G); H)  assoc')
    by simp
  show register (F; (G; H))
    by simp
  show (((F; G); H)  assoc') (f u g u h) = (F; (G; H)) (f u g u h) for f g h
    by (simp add: register_pair_apply assoc'_apply cblinfun_compose_assoc)
qed

lemma assoc'_o_assoc[simp]: assoc' o assoc = id
  apply (rule tensor_extensionality3')
  by auto

lemma assoc'_assoc[simp]: assoc' (assoc x) = x
  by (simp add: pointfree_idE)

lemma assoc_o_assoc'[simp]: assoc o assoc' = id
  apply (rule tensor_extensionality3)
  by auto

lemma assoc_assoc'[simp]: assoc (assoc' x) = x
  by (simp add: pointfree_idE)

lemma inv_assoc[simp]: inv assoc = assoc'
  using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast

lemma inv_assoc'[simp]: inv assoc' = assoc
  by (simp add: inv_equality)

lemma [simp]: bij assoc
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

lemma [simp]: bij assoc'
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

subsection Iso-registers

definition iso_register F  register F  (G. register G  F o G = id  G o F = id)
  for F :: _::finite update  _::finite update

lemma iso_registerI:
  assumes register F register G F o G = id G o F = id
  shows iso_register F
  using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast

lemma iso_register_inv: iso_register F  iso_register (inv F)
  by (metis inv_unique_comp iso_register_def)

lemma iso_register_inv_comp1: iso_register F  inv F o F = id
  using inv_unique_comp iso_register_def by blast

lemma iso_register_inv_comp2: iso_register F  F o inv F = id
  using inv_unique_comp iso_register_def by blast


lemma iso_register_id[simp]: iso_register id
  by (simp add: iso_register_def)

lemma iso_register_is_register: iso_register F  register F
  using iso_register_def by blast

lemma iso_register_comp[simp]:
  assumes [simp]: iso_register F iso_register G
  shows iso_register (F o G)
proof -
  from assms obtain F' G' where [simp]: register F' register G' F o F' = id F' o F = id
    G o G' = id G' o G = id
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=G' o F'])
       apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
     apply (metis F  F' = id G  G' = id fcomp_assoc fcomp_comp id_fcomp)
    by (metis (no_types, lifting) F  F' = id F'  F = id G'  G = id fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed


lemma iso_register_tensor_is_iso_register[simp]:
  assumes [simp]: iso_register F iso_register G
  shows iso_register (F r G)
proof -
  from assms obtain F' G' where [simp]: register F' register G' F o F' = id F' o F = id
    G o G' = id G' o G = id
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=F' r G'])
    by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed

lemma iso_register_bij: iso_register F  bij F
  using iso_register_def o_bij by auto

lemma inv_register_tensor[simp]: 
  assumes [simp]: iso_register F iso_register G
  shows inv (F r G) = inv F r inv G
  apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij 
              simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                    iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
  by (metis eq_id_iff register_tensor_id)

lemma iso_register_swap[simp]: iso_register swap
  apply (rule iso_registerI[of _ swap])
  by auto

lemma iso_register_assoc[simp]: iso_register assoc
  apply (rule iso_registerI[of _ assoc'])
  by auto

lemma iso_register_assoc'[simp]: iso_register assoc'
  apply (rule iso_registerI[of _ assoc])
  by auto

definition equivalent_registers F G  (register F  (I. iso_register I  F o I = G))
  for F G :: _::finite update  _::finite update

lemma iso_register_equivalent_id[simp]: equivalent_registers id F  iso_register F
  by (simp add: equivalent_registers_def)

lemma equivalent_registersI:
  assumes register F
  assumes iso_register I
  assumes F o I = G
  shows equivalent_registers F G
  using assms unfolding equivalent_registers_def by blast

lemma equivalent_registers_register_left: equivalent_registers F G  register F
  using equivalent_registers_def by auto

lemma equivalent_registers_register_right: register G if equivalent_registers F G
  by (metis equivalent_registers_def iso_register_def register_comp that)

lemma equivalent_registers_sym:
  assumes equivalent_registers F G
  shows equivalent_registers G F
  by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)

lemma equivalent_registers_trans[trans]: 
  assumes equivalent_registers F G and equivalent_registers G H
  shows equivalent_registers F H
proof -
  from assms have [simp]: register F register G
    by (auto simp: equivalent_registers_def)
  from assms(1) obtain I where [simp]: iso_register I and F o I = G
    using equivalent_registers_def by blast
  from assms(2) obtain J where [simp]: iso_register J and G o J = H
    using equivalent_registers_def by blast
  have register F
    by (auto simp: equivalent_registers_def)
  moreover have iso_register (I o J)
    using iso_register I iso_register J iso_register_comp by blast
  moreover have F o (I o J) = H
    by (simp add: F  I = G G  J = H o_assoc)
  ultimately show ?thesis
    by (rule equivalent_registersI)
qed

lemma equivalent_registers_assoc[simp]:
  assumes [simp]: compatible F G compatible F H compatible G H
  shows equivalent_registers (F;(G;H)) ((F;G);H)
  apply (rule equivalent_registersI[where I=assoc])
  by auto

lemma equivalent_registers_pair_right:
  assumes [simp]: compatible F G
  assumes eq: equivalent_registers G H
  shows equivalent_registers (F;G) (F;H)
proof -
  from eq obtain I where [simp]: iso_register I and G o I = H
    by (metis equivalent_registers_def)
  then have *: (F;G)  (id r I) = (F;H)
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=id r I])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_pair_left:
  assumes [simp]: compatible F G
  assumes eq: equivalent_registers F H
  shows equivalent_registers (F;G) (H;G)
proof -
  from eq obtain I where [simp]: iso_register I and F o I = H
    by (metis equivalent_registers_def)
  then have *: (F;G)  (I r id) = (H;G)
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=I r id])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_comp:
  assumes register H
  assumes equivalent_registers F G
  shows equivalent_registers (H o F) (H o G)
  by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)

subsection Compatibility simplification

text The simproc compatibility_warn› produces helpful warnings for subgoals of the form
   termcompatible x y that are probably unsolvable due to missing declarations of 
   variable compatibility facts. Same for subgoals of the form termregister x.
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = 
let val thy_string = Markup.markup (Theory.get_markup theory) (Context.theory_name theory)
in
fn m => fn ctxt => fn ct => let
  val (x,y) = case Thm.term_of ct of
                 Const(const_namecompatible,_ ) $ x $ y => (x, SOME y)
               | Const(const_nameregister,_ ) $ x => (x, NONE)
  val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
  fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
  val _ = case (x,y) of
        (Free(n,T), SOME (Free(n',T'))) => 
            if String.isPrefix ":" n orelse String.isPrefix ":" n' then 
                      w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else if n=n' then (if T=T' then () 
                          else w ("In simplification subgoal " ^ Lazy.force str ^ 
                               ", variables have same name and different types.\n" ^
                               "Probably something is wrong."))
                    else w ("Simplification subgoal " ^ Lazy.force str ^ 
                            " occurred but cannot be solved.\n" ^
                            "Please add assumption/fact  [simp]: ‹" ^ Lazy.force str ^ 
                            "›  somewhere.")
      | (Free(n,T), NONE) => 
            if String.isPrefix ":" n then 
                      w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                    "Please add assumption/fact  [simp]: ‹" ^ Lazy.force str ^ "›  somewhere.")
      | _ => ()
  in NONE end
end


named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule

lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
  asm_rl[of compatible _ _] asm_rl[of iso_register _] asm_rl[of register _] iso_register_inv

text The following declares an attribute [register]›. When the attribute is applied to a fact
  of the form termregister F, termiso_register F, termcompatible F G or a conjunction of these,
  then those facts are added to the simplifier together with some derived theorems
  (e.g., termcompatible F G also adds termregister F).

  In theory Laws_Complement›, support for termis_unit_register F and termcomplements F G is
  added to this attribute.

setup 
let
fun add thm results = 
  Net.insert_term (K true) (Thm.concl_of thm, thm) results
  handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
  NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
  results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
  val ctxt = Context.proof_of context
  val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
  val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
  val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
  (* val _ = print thms *)
  in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup bindingregister
 (Scan.succeed (Thm.declaration_attribute declare))
  "Add register-related rules to the simplifier"
end


subsection Notation

no_notation cblinfun_compose (infixl "*u" 55)
no_notation tensor_op (infixr "u" 70)

bundle register_notation begin
notation register_tensor (infixr "r" 70)
notation register_pair ("'(_;_')")
end

bundle no_register_notation begin
no_notation register_tensor (infixr "r" 70)
no_notation register_pair ("'(_;_')")
end

end

Theory Quantum

section Quantum mechanics basics

theory Quantum
  imports
    Finite_Tensor_Product
    "HOL-Library.Z2"
    Jordan_Normal_Form.Matrix_Impl 
    Real_Impl.Real_Impl
    "HOL-Library.Code_Target_Numeral"
begin

type_synonym ('a,'b) matrix = ('a ell2, 'b ell2) cblinfun

subsection Basic quantum states

subsubsection EPR pair

definition "vector_β00 = vec_of_list [ 1/sqrt 2::complex, 0, 0, 1/sqrt 2 ]"
definition β00 :: (bit×bit) ell2 where [code del]: "β00 = basis_enum_of_vec vector_β00"
lemma vec_of_basis_enum_β00[simp]: "vec_of_basis_enum β00 = vector_β00"
  by (auto simp add: β00_def vector_β00_def)
lemma vec_of_ell2_β00[simp, code]: "vec_of_ell2 β00 = vector_β00"
  by (simp add: vec_of_ell2_def)

lemma norm_β00[simp]: "norm β00 = 1"
  by eval

subsubsection Ket plus

definition "vector_ketplus = vec_of_list [ 1/sqrt 2::complex, 1/sqrt 2 ]"
definition ketplus :: bit ell2 ("|+⟩") where [code del]: ketplus = basis_enum_of_vec vector_ketplus
lemma vec_of_basis_enum_ketplus[simp]: "vec_of_basis_enum ketplus = vector_ketplus"
  by (auto simp add: ketplus_def vector_ketplus_def)
lemma vec_of_ell2_ketplus[simp, code]: "vec_of_ell2 ketplus = vector_ketplus"
  by (simp add: vec_of_ell2_def)

subsection Basic quantum gates

subsubsection Pauli X

definition "matrix_pauliX = mat_of_rows_list 2 [ [0::complex, 1], [1, 0] ]"
definition pauliX :: (bit, bit) matrix where [code del]: "pauliX = cblinfun_of_mat matrix_pauliX"
lemma [simp, code]: "mat_of_cblinfun pauliX = matrix_pauliX"
  apply (auto simp add: pauliX_def matrix_pauliX_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

derive (eq) ceq bit

instantiation bit :: ccompare begin
definition "CCOMPARE(bit) = Some (λb1 b2. case (b1, b2) of (0, 0)  order.Eq | (0, 1)  order.Lt | (1, 0)  order.Gt | (1, 1)  order.Eq)"
instance 
  by intro_classes(unfold_locales; auto simp add: ccompare_bit_def split!: bit.splits)
end

derive (dlist) set_impl bit

lemma pauliX_adjoint[simp]: "pauliX* = pauliX"
  by eval
lemma pauliXX[simp]: "pauliX oCL pauliX = id_cblinfun"
  by eval

subsubsection Pauli Z

definition "matrix_pauliZ = mat_of_rows_list 2 [ [1::complex, 0], [0, -1] ]"
definition pauliZ :: (bit, bit) matrix where [code del]: "pauliZ = cblinfun_of_mat matrix_pauliZ"
lemma [simp, code]: "mat_of_cblinfun pauliZ = matrix_pauliZ"
  apply (auto simp add: pauliZ_def matrix_pauliZ_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)
lemma pauliZ_adjoint[simp]: "pauliZ* = pauliZ"
  by eval
lemma pauliZZ[simp]: "pauliZ oCL pauliZ = id_cblinfun"
  by eval


subsubsection Hadamard

definition "matrix_hadamard = mat_of_rows_list 2 [ [1/sqrt 2::complex, 1/sqrt 2], [1/sqrt 2, -1/sqrt 2] ]"
definition hadamard :: (bit,bit) matrix where [code del]: "hadamard = cblinfun_of_mat matrix_hadamard"

lemma [simp, code]: "mat_of_cblinfun hadamard = matrix_hadamard"
  apply (auto simp add: hadamard_def matrix_hadamard_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

lemma hada_adj[simp]: "hadamard* = hadamard"
  by eval


subsubsection CNOT

definition "matrix_CNOT = mat_of_rows_list 4 [ [1::complex,0,0,0], [0,1,0,0], [0,0,0,1], [0,0,1,0] ]"
definition CNOT :: (bit*bit, bit*bit) matrix where [code del]: "CNOT = cblinfun_of_mat matrix_CNOT"

lemma [simp, code]: "mat_of_cblinfun CNOT = matrix_CNOT"
  apply (auto simp add: CNOT_def matrix_CNOT_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

lemma [simp]: "CNOT* = CNOT"
  by eval

lemma cnot_apply[simp]: CNOT *V ket (i,j) = ket (i,j+i)
  apply (rule spec[where x=i], rule spec[where x=j])
  by eval

subsubsection Qubit swap


definition "matrix_Uswap = mat_of_rows_list 4 [ [1::complex, 0, 0, 0], [0,0,1,0], [0,1,0,0], [0,0,0,1] ]"
definition Uswap :: (bit×bit, bit×bit) matrix where
  [code del]: Uswap = cblinfun_of_mat matrix_Uswap

lemma mat_of_cblinfun_Uswap[simp, code]: "mat_of_cblinfun Uswap = matrix_Uswap"
  apply (auto simp add: Uswap_def matrix_Uswap_def)
  apply (subst cblinfun_of_mat_inverse)
  by (auto)

lemma dim_col_Uswap[simp]: "dim_col matrix_Uswap = 4"
  unfolding matrix_Uswap_def by simp
lemma dim_row_Uswap[simp]: "dim_row matrix_Uswap = 4"
  unfolding matrix_Uswap_def by simp
lemma Uswap_adjoint[simp]: "Uswap* = Uswap"
  by eval
lemma Uswap_involution[simp]: "Uswap oCL Uswap = id_cblinfun"
  by eval
lemma unitary_Uswap[simp]: "unitary Uswap"
  unfolding unitary_def by simp

lemma Uswap_apply[simp]: Uswap *V s s t = t s s
  apply (rule clinear_equal_ket[where f=λs. Uswap *V s s t, THEN fun_cong])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
   apply (simp add: clinear_tensor_ell21)
  apply (rule clinear_equal_ket[where f=λt. Uswap *V _ s t, THEN fun_cong])
    apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
   apply (simp add: clinear_tensor_ell22)
  apply (rule basis_enum_eq_vec_of_basis_enumI)
  apply (simp add: mat_of_cblinfun_cblinfun_apply vec_of_basis_enum_ket)
  by (case_tac i; case_tac ia; hypsubst_thin; normalization)

end

Theory Quantum_Extra

section Derived facts about quantum registers

theory Quantum_Extra
  imports
    Laws_Quantum
    Quantum
begin

no_notation meet (infixl "ı" 70)
no_notation Group.mult (infixl "ı" 70)
no_notation Order.top ("ı")
unbundle register_notation
unbundle cblinfun_notation

lemma register_id'[simp]: register (λx. x)
  using register_id by (simp add: id_def)

lemma register_projector:
  assumes "register F"
  assumes "is_Proj a"
  shows "is_Proj (F a)"
  using assms unfolding register_def is_Proj_algebraic by metis

lemma register_unitary:
  assumes "register F"
  assumes "unitary a"
  shows "unitary (F a)"
  using assms by (smt (verit, best) register_def unitary_def)

lemma compatible_proj_intersect:
  (* I think this also holds without is_Proj premises, but my proof ideas use the Penrose-Moore 
     pseudoinverse or simultaneous diagonalization and we do not have an existence theorem for either. *)
  assumes "compatible R S" and "is_Proj a" and "is_Proj b"
  shows "(R a *S )  (S b *S ) = ((R a oCL S b) *S )"
proof (rule antisym)
  have "((R a oCL S b) *S )  (S b *S )"
    apply (subst swap_registers[OF assms(1)])
    by (simp add: cblinfun_compose_image cblinfun_image_mono)
  moreover have "((R a oCL S b) *S )  (R a *S )"
    by (simp add: cblinfun_compose_image cblinfun_image_mono)
  ultimately show ((R a oCL S b) *S )  (R a *S )  (S b *S )
    by auto

  have "is_Proj (R a)"
    using assms(1) assms(2) compatible_register1 register_projector by blast
  have "is_Proj (S b)"
    using assms(1) assms(3) compatible_register2 register_projector by blast
  show (R a *S )  (S b *S )  (R a oCL S b) *S 
  proof (unfold less_eq_ccsubspace.rep_eq, rule)
    fix ψ
    assume asm: ψ  space_as_set ((R a *S )  (S b *S ))
    then have ψ  space_as_set (R a *S )
      by auto
    then have R: R a *V ψ = ψ
      using is_Proj (R a) cblinfun_fixes_range is_Proj_algebraic by blast
    from asm have ψ  space_as_set (S b *S )
      by auto
    then have S: S b *V ψ = ψ
      using is_Proj (S b) cblinfun_fixes_range is_Proj_algebraic by blast
    from R S have ψ = (R a oCL S b) *V ψ
      by (simp add: cblinfun_apply_cblinfun_compose)
    also have   space_as_set ((R a oCL S b) *S )
      apply simp by (metis R S calculation cblinfun_apply_in_image)
    finally show ψ  space_as_set ((R a oCL S b) *S )
      by -
  qed
qed

lemma compatible_proj_mult:
  assumes "compatible R S" and "is_Proj a" and "is_Proj b"
  shows "is_Proj (R a oCL S b)"
  using [[simproc del: Laws_Quantum.compatibility_warn]]
  using assms unfolding is_Proj_algebraic compatible_def
  apply auto
   apply (metis (no_types, lifting) cblinfun_compose_assoc register_mult)
  by (simp add: assms(2) assms(3) is_proj_selfadj register_projector)

lemma unitary_sandwich_register: unitary a  register (sandwich a)
  unfolding register_def
  apply (auto simp: sandwich_def)
   apply (metis (no_types, lifting) cblinfun_assoc_left(1) cblinfun_compose_id_right unitaryD1)
  by (simp add: lift_cblinfun_comp(2))

lemma sandwich_tensor: 
  fixes a :: 'a::finite ell2 CL 'a ell2 and b :: 'b::finite ell2 CL 'b ell2 
  assumes unitary a unitary b
  shows "sandwich (a o b) = sandwich a r sandwich b"
  apply (rule tensor_extensionality)
  by (auto simp: unitary_sandwich_register assms sandwich_def register_tensor_is_register comp_tensor_op tensor_op_adjoint)

lemma sandwich_grow_left: 
  fixes a :: 'a::finite ell2 CL 'a ell2
  assumes "unitary a"
  shows "sandwich a r id = sandwich (a o id_cblinfun)"
  by (simp add: unitary_sandwich_register assms sandwich_tensor sandwich_id)

lemma register_sandwich: register F  F (sandwich a b) = sandwich (F a) (F b)
  by (smt (verit, del_insts) register_def sandwich_def)

lemma assoc_ell2_sandwich: assoc = sandwich assoc_ell2
  apply (rule tensor_extensionality3')
    apply (simp_all add: unitary_sandwich_register)[2]
  apply (rule equal_ket)
  apply (case_tac x)
  by (simp add: sandwich_def assoc_apply cblinfun_apply_cblinfun_compose tensor_op_ell2 assoc_ell2_tensor assoc_ell2'_tensor
           flip: tensor_ell2_ket)

lemma assoc_ell2'_sandwich: assoc' = sandwich assoc_ell2'
  apply (rule tensor_extensionality3)
    apply (simp_all add: unitary_sandwich_register)[2]
  apply (rule equal_ket)
  apply (case_tac x)
  by (simp add: sandwich_def assoc'_apply cblinfun_apply_cblinfun_compose tensor_op_ell2 assoc_ell2_tensor assoc_ell2'_tensor 
           flip: tensor_ell2_ket)

lemma swap_sandwich: "swap = sandwich Uswap"
  apply (rule tensor_extensionality)
    apply (auto simp: sandwich_def)[2]
  apply (rule tensor_ell2_extensionality)
  by (simp add: sandwich_def cblinfun_apply_cblinfun_compose tensor_op_ell2)

lemma id_tensor_sandwich: 
  fixes a :: "'a::finite ell2 CL 'b::finite ell2"
  assumes "unitary a"
  shows "id r sandwich a = sandwich (id_cblinfun o a)"
  apply (rule tensor_extensionality) 
  using assms by (auto simp: register_tensor_is_register comp_tensor_op sandwich_def tensor_op_adjoint unitary_sandwich_register)

lemma compatible_selfbutter_join:
  assumes [register]: "compatible R S"
  shows "R (selfbutter ψ) oCL S (selfbutter φ) = (R; S) (selfbutter (ψ s φ))"
  apply (subst register_pair_apply[symmetric, where F=R and G=S])
  using assms by auto

lemma register_mult':
  assumes register F
  shows F a *V F b *V c = F (a oCL b) *V c
  by (simp add: assms lift_cblinfun_comp(4) register_mult)

lemma register_scaleC:
  assumes register F shows F (c *C a) = c *C F a
  by (simp add: assms complex_vector.linear_scale)

lemma register_bounded_clinear: register F  bounded_clinear F
  using bounded_clinear_finite_dim register_def by blast

lemma register_adjoint: "F (a*) = (F a)*" if register F
  using register_def that by blast

end

Theory QHoare

section Very simple Quantum Hoare logic

theory QHoare
  imports Quantum_Extra
begin

no_notation Order.top ("ı")

locale qhoare =
  fixes memory_type :: "'mem::finite itself"
begin

definition "apply U R = R U" for R :: 'a update  'mem update
definition "ifthen R x = R (butterket x x)" for R :: 'a update  'mem update
definition "program S = fold (oCL) S id_cblinfun" for S :: 'mem update list


definition hoare :: 'mem ell2 ccsubspace  ('mem ell2 CL 'mem ell2) list  'mem ell2 ccsubspace  bool where
  "hoare C p D  (ψspace_as_set C. program p *V ψ  space_as_set D)" for C p D

definition EQ :: "('a update  'mem update)  'a ell2  'mem ell2 ccsubspace" (infix "=q" 75) where
  "EQ R ψ = R (selfbutter ψ) *S "

lemma program_skip[simp]: "program [] = id_cblinfun"
  by (simp add: qhoare.program_def)

lemma program_seq: "program (p1@p2) = program p2 oCL program p1"
  apply (induction p2 rule:rev_induct)
   apply (simp_all add: program_def)
  by (meson cblinfun_assoc_left(1))

lemma hoare_seq[trans]: "hoare C p1 D  hoare D p2 E  hoare C (p1@p2) E"
  by (auto simp: program_seq hoare_def)

lemma hoare_weaken_left[trans]: A  B  hoare B p C  hoare A p C
  unfolding hoare_def
  by (meson in_mono less_eq_ccsubspace.rep_eq) 

lemma hoare_weaken_right[trans]: hoare A p B  B  C  hoare A p C
  unfolding hoare_def 
  by (meson in_mono less_eq_ccsubspace.rep_eq) 

lemma hoare_skip: "C  D  hoare C [] D"
  by (auto simp: program_def hoare_def in_mono less_eq_ccsubspace.rep_eq)

lemma hoare_apply: 
  assumes "R U *S pre  post"
  shows "hoare pre [apply U R] post"
  using assms 
  apply (auto simp: hoare_def program_def apply_def)
  by (metis (no_types, lifting) cblinfun_image.rep_eq closure_subset imageI less_eq_ccsubspace.rep_eq subsetD)

lemma hoare_ifthen: 
  fixes R :: 'a update  'mem update
  assumes "R (selfbutter (ket x)) *S pre  post"
  shows "hoare pre [ifthen R x] post"
  using assms 
  apply (auto simp: hoare_def program_def ifthen_def butterfly_def)
  by (metis (no_types, lifting) cblinfun_image.rep_eq closure_subset imageI less_eq_ccsubspace.rep_eq subsetD)

end

end

Theory Finite_Tensor_Product_Matrices

section Tensor products as matrices

theory Finite_Tensor_Product_Matrices
  imports Finite_Tensor_Product
begin

definition tensor_pack :: "nat  nat  (nat × nat)  nat"
  where "tensor_pack X Y = (λ(x, y). x * Y + y)"

definition tensor_unpack :: "nat  nat  nat  (nat × nat)"
  where "tensor_unpack X Y xy = (xy div Y, xy mod Y)"

lemma tensor_unpack_inj:
  assumes "i < A * B" and "j < A * B"
  shows "tensor_unpack A B i = tensor_unpack A B j  i = j"
  by (metis div_mult_mod_eq prod.sel(1) prod.sel(2) tensor_unpack_def)

lemma tensor_unpack_bound1[simp]: "i < A * B  fst (tensor_unpack A B i) < A"
  unfolding tensor_unpack_def
  apply auto
  using less_mult_imp_div_less by blast
lemma tensor_unpack_bound2[simp]: "i < A * B  snd (tensor_unpack A B i) < B"
  unfolding tensor_unpack_def
  apply auto
  by (metis mod_less_divisor mult.commute mult_zero_left nat_neq_iff not_less0)

lemma tensor_unpack_fstfst: fst (tensor_unpack A B (fst (tensor_unpack (A * B) C i)))
     = fst (tensor_unpack A (B * C) i)
  unfolding tensor_unpack_def apply auto
  by (metis div_mult2_eq mult.commute)
lemma tensor_unpack_sndsnd: snd (tensor_unpack B C (snd (tensor_unpack A (B * C) i)))
     = snd (tensor_unpack (A * B) C i)
  unfolding tensor_unpack_def apply auto
  by (meson dvd_triv_right mod_mod_cancel)
lemma tensor_unpack_fstsnd: fst (tensor_unpack B C (snd (tensor_unpack A (B * C) i)))
     = snd (tensor_unpack A B (fst (tensor_unpack (A * B) C i)))
  unfolding tensor_unpack_def apply auto
  by (metis (no_types, lifting) Euclidean_Division.div_eq_0_iff add_0_iff bits_mod_div_trivial div_mult_self4 mod_mult2_eq mod_mult_self1_is_0 mult.commute)


definition "tensor_state_jnf ψ φ = (let d1 = dim_vec ψ in let d2 = dim_vec φ in
  vec (d1*d2) (λi. let (i1,i2) = tensor_unpack d1 d2 i in (vec_index ψ i1) * (vec_index φ i2)))"

lemma tensor_state_jnf_dim[simp]: dim_vec (tensor_state_jnf ψ φ) = dim_vec ψ * dim_vec φ
  unfolding tensor_state_jnf_def Let_def by simp

lemma enum_prod_nth_tensor_unpack:
  assumes i < CARD('a) * CARD('b)
  shows "(Enum.enum ! i :: 'a::enum×'b::enum) = 
        (let (i1,i2) = tensor_unpack CARD('a) CARD('b) i in 
              (Enum.enum ! i1, Enum.enum ! i2))"
  using assms 
  by (simp add: enum_prod_def card_UNIV_length_enum product_nth tensor_unpack_def)

lemma vec_of_basis_enum_tensor_state_index:
  fixes ψ :: 'a::enum ell2 and φ :: 'b::enum ell2
  assumes [simp]: i < CARD('a) * CARD('b)
  shows vec_of_basis_enum (ψ s φ) $ i = (let (i1,i2) = tensor_unpack CARD('a) CARD('b) i in
    vec_of_basis_enum ψ $ i1 * vec_of_basis_enum φ $ i2)
proof -
  define i1 i2 where "i1 = fst (tensor_unpack CARD('a) CARD('b) i)"
    and "i2 = snd (tensor_unpack CARD('a) CARD('b) i)"
  have [simp]: "i1 < CARD('a)" "i2 < CARD('b)"
    using assms i1_def tensor_unpack_bound1 apply presburger
    using assms i2_def tensor_unpack_bound2 by presburger

  have vec_of_basis_enum (ψ s φ) $ i = Rep_ell2 (ψ s φ) (enum_class.enum ! i)
    by (simp add: vec_of_basis_enum_ell2_component)
  also have  = Rep_ell2 ψ (Enum.enum!i1) * Rep_ell2 φ (Enum.enum!i2)
    apply (transfer fixing: i i1 i2)
    by (simp add: enum_prod_nth_tensor_unpack case_prod_beta i1_def i2_def)
  also have  = vec_of_basis_enum ψ $ i1 * vec_of_basis_enum φ $ i2
    by (simp add: vec_of_basis_enum_ell2_component)
  finally show ?thesis
    by (simp add: case_prod_beta i1_def i2_def)
qed

lemma vec_of_basis_enum_tensor_state:
  fixes ψ :: 'a::enum ell2 and φ :: 'b::enum ell2
  shows vec_of_basis_enum (ψ s φ) = tensor_state_jnf (vec_of_basis_enum ψ) (vec_of_basis_enum φ)
  apply (rule eq_vecI, simp_all)
  apply (subst vec_of_basis_enum_tensor_state_index, simp_all)
  by (simp add: tensor_state_jnf_def case_prod_beta Let_def)


lemma mat_of_cblinfun_tensor_op_index:
  fixes a :: 'a::enum ell2 CL 'b::enum ell2 and b :: 'c::enum ell2 CL 'd::enum ell2
  assumes [simp]: i < CARD('b) * CARD('d)
  assumes [simp]: j < CARD('a) * CARD('c)
  shows mat_of_cblinfun (tensor_op a b) $$ (i,j) = 
            (let (i1,i2) = tensor_unpack CARD('b) CARD('d) i in
             let (j1,j2) = tensor_unpack CARD('a) CARD('c) j in
                  mat_of_cblinfun a $$ (i1,j1) * mat_of_cblinfun b $$ (i2,j2))
proof -
  define i1 i2 j1 j2
    where "i1 = fst (tensor_unpack CARD('b) CARD('d) i)"
      and "i2 = snd (tensor_unpack CARD('b) CARD('d) i)"
      and "j1 = fst (tensor_unpack CARD('a) CARD('c) j)"
      and "j2 = snd (tensor_unpack CARD('a) CARD('c) j)"
  have [simp]: "i1 < CARD('b)" "i2 < CARD('d)" "j1 < CARD('a)" "j2 < CARD('c)"
    using assms i1_def tensor_unpack_bound1 apply presburger
    using assms i2_def tensor_unpack_bound2 apply blast
    using assms(2) j1_def tensor_unpack_bound1 apply blast
    using assms(2) j2_def tensor_unpack_bound2 by presburger

  have mat_of_cblinfun (tensor_op a b) $$ (i,j) 
       = Rep_ell2 (tensor_op a b *V ket (Enum.enum!j)) (Enum.enum ! i)
    by (simp add: mat_of_cblinfun_ell2_component)
  also have  = Rep_ell2 ((a *V ket (Enum.enum!j1)) s (b *V ket (Enum.enum!j2))) (Enum.enum!i)
    by (simp add: tensor_op_ell2 enum_prod_nth_tensor_unpack[where i=j] Let_def case_prod_beta j1_def[symmetric] j2_def[symmetric] flip: tensor_ell2_ket)
  also have  = vec_of_basis_enum ((a *V ket (Enum.enum!j1)) s b *V ket (Enum.enum!j2)) $ i
    by (simp add: vec_of_basis_enum_ell2_component)
  also have  = vec_of_basis_enum (a *V ket (enum_class.enum ! j1)) $ i1 *
                  vec_of_basis_enum (b *V ket (enum_class.enum ! j2)) $ i2
    by (simp add: case_prod_beta vec_of_basis_enum_tensor_state_index i1_def[symmetric] i2_def[symmetric])
  also have  = Rep_ell2 (a *V ket (enum_class.enum ! j1)) (enum_class.enum ! i1) *
                  Rep_ell2 (b *V ket (enum_class.enum ! j2)) (enum_class.enum ! i2)
    by (simp add: vec_of_basis_enum_ell2_component)
  also have  = mat_of_cblinfun a $$ (i1, j1) * mat_of_cblinfun b $$ (i2, j2)
    by (simp add: mat_of_cblinfun_ell2_component)
  finally show ?thesis
    by (simp add: i1_def[symmetric] i2_def[symmetric] j1_def[symmetric] j2_def[symmetric] case_prod_beta)
qed


definition "tensor_op_jnf A B = 
  (let r1 = dim_row A in
   let c1 = dim_col A in
   let r2 = dim_row B in
   let c2 = dim_col B in
   mat (r1*r2) (c1*c2)
   (λ(i,j). let (i1,i2) = tensor_unpack r1 r2 i in
            let (j1,j2) = tensor_unpack c1 c2 j in
              (A $$ (i1,j1)) * (B $$ (i2,j2))))"

lemma tensor_op_jnf_dim[simp]: 
  dim_row (tensor_op_jnf a b) = dim_row a * dim_row b
  dim_col (tensor_op_jnf a b) = dim_col a * dim_col b
  unfolding tensor_op_jnf_def Let_def by simp_all


lemma mat_of_cblinfun_tensor_op:
  fixes a :: 'a::enum ell2 CL 'b::enum ell2 and b :: 'c::enum ell2 CL 'd::enum ell2
  shows mat_of_cblinfun (tensor_op a b) = tensor_op_jnf (mat_of_cblinfun a) (mat_of_cblinfun b)
  apply (rule eq_matI, simp_all add: )
  apply (subst mat_of_cblinfun_tensor_op_index, simp_all)
  by (simp add: tensor_op_jnf_def case_prod_beta Let_def)


lemma mat_of_cblinfun_assoc_ell2'[simp]: 
  mat_of_cblinfun (assoc_ell2' :: (('a::enum×('b::enum×'c::enum)) ell2 CL _)) = one_mat (CARD('a)*CARD('b)*CARD('c))
  (is "mat_of_cblinfun ?assoc = _")
proof  (rule mat_eq_iff[THEN iffD2], intro conjI allI impI)

  show dim_row (mat_of_cblinfun ?assoc) =
    dim_row (1m (CARD('a) * CARD('b) * CARD('c)))
    by (simp)
  show dim_col (mat_of_cblinfun ?assoc) =
    dim_col (1m (CARD('a) * CARD('b) * CARD('c)))
    by (simp)

  fix i j
  let ?i = "Enum.enum ! i :: (('a×'b)×'c)" and ?j = "Enum.enum ! j :: ('a×('b×'c))"

  assume i < dim_row (1m (CARD('a) * CARD('b) * CARD('c)))
  then have iB[simp]: i < CARD('a) * CARD('b) * CARD('c) by simp
  then have iB'[simp]: i < CARD('a) * (CARD('b) * CARD('c)) by linarith
  assume j < dim_col (1m (CARD('a) * CARD('b) * CARD('c)))
  then have jB[simp]: j < CARD('a) * CARD('b) * CARD('c) by simp
  then have jB'[simp]: j < CARD('a) * (CARD('b) * CARD('c)) by linarith

  define i1 i23 i2 i3
    where "i1 = fst (tensor_unpack CARD('a) (CARD('b)*CARD('c)) i)"
      and "i23 = snd (tensor_unpack CARD('a) (CARD('b)*CARD('c)) i)"
      and "i2 = fst (tensor_unpack CARD('b) CARD('c) i23)"
      and "i3 = snd (tensor_unpack CARD('b) CARD('c) i23)"
  define j12 j1 j2 j3
    where "j12 = fst (tensor_unpack (CARD('a)*CARD('b)) CARD('c) j)"
      and "j1 = fst (tensor_unpack CARD('a) CARD('b) j12)"
      and "j2 = snd (tensor_unpack CARD('a) CARD('b) j12)"
      and "j3 = snd (tensor_unpack (CARD('a)*CARD('b)) CARD('c) j)"

  have [simp]: "j12 < CARD('a)*CARD('b)" "i23 < CARD('b)*CARD('c)"
    using j12_def jB tensor_unpack_bound1 apply presburger
    using i23_def iB' tensor_unpack_bound2 by blast

  have j1': fst (tensor_unpack CARD('a) (CARD('b) * CARD('c)) j) = j1
    by (simp add: j1_def j12_def tensor_unpack_fstfst)

  let ?i1 = "Enum.enum ! i1 :: 'a" and ?i2 = "Enum.enum ! i2 :: 'b" and ?i3 = "Enum.enum ! i3 :: 'c"
  let ?j1 = "Enum.enum ! j1 :: 'a" and ?j2 = "Enum.enum ! j2 :: 'b" and ?j3 = "Enum.enum ! j3 :: 'c"

  have i: ?i = ((?i1,?i2),?i3)
    by (auto simp add: enum_prod_nth_tensor_unpack case_prod_beta
          tensor_unpack_fstfst tensor_unpack_fstsnd tensor_unpack_sndsnd i1_def i2_def i23_def i3_def)
  have j: ?j = (?j1,(?j2,?j3)) 
    by (auto simp add: enum_prod_nth_tensor_unpack case_prod_beta
        tensor_unpack_fstfst tensor_unpack_fstsnd tensor_unpack_sndsnd j1_def j2_def j12_def j3_def)
  have ijeq: (?i1,?i2,?i3) = (?j1,?j2,?j3)  i = j
    unfolding i1_def i2_def i3_def j1_def j2_def j3_def apply simp
    apply (subst enum_inj, simp, simp)
    apply (subst enum_inj, simp, simp)
    apply (subst enum_inj, simp, simp)
    apply (subst tensor_unpack_inj[symmetric, where i=i and j=j and A="CARD('a)" and B="CARD('b)*CARD('c)"], simp, simp)
    unfolding prod_eq_iff
    apply (subst tensor_unpack_inj[symmetric, where i=snd (tensor_unpack CARD('a) (CARD('b) * CARD('c)) i) and A="CARD('b)" and B="CARD('c)"], simp, simp)
    by (simp add: i1_def[symmetric] j1_def[symmetric] i2_def[symmetric] j2_def[symmetric] i3_def[symmetric] j3_def[symmetric]
        i23_def[symmetric] j12_def[symmetric] j1'
        prod_eq_iff tensor_unpack_fstsnd tensor_unpack_sndsnd)

  have mat_of_cblinfun ?assoc $$ (i, j) = Rep_ell2 (assoc_ell2' *V ket ?j) ?i
    by (subst mat_of_cblinfun_ell2_component, auto)
  also have  = Rep_ell2 ((ket ?j1 s ket ?j2) s ket ?j3) ?i
    by (simp add: j assoc_ell2'_tensor flip: tensor_ell2_ket)
  also have  = (if (?i1,?i2,?i3) = (?j1,?j2,?j3) then 1 else 0)
    by (auto simp add: ket.rep_eq i)
  also have  = (if i=j then 1 else 0)
    using ijeq by simp
  finally
  show mat_of_cblinfun ?assoc $$ (i, j) =
           1m (CARD('a) * CARD('b) * CARD('c)) $$ (i, j)
    by auto
qed

lemma assoc_ell2'_inv: "assoc_ell2 oCL assoc_ell2' = id_cblinfun"
  apply (rule equal_ket, case_tac x, hypsubst)
  by (simp flip: tensor_ell2_ket add: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor)

lemma assoc_ell2_inv: "assoc_ell2' oCL assoc_ell2 = id_cblinfun"
  apply (rule equal_ket, case_tac x, hypsubst)
  by (simp flip: tensor_ell2_ket add: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor)

lemma mat_of_cblinfun_assoc_ell2[simp]: 
  mat_of_cblinfun (assoc_ell2 :: ((('a::enum×'b::enum)×'c::enum) ell2 CL _)) = one_mat (CARD('a)*CARD('b)*CARD('c))
  (is "mat_of_cblinfun ?assoc = _")
proof -
  let ?assoc' = "assoc_ell2' :: (('a::enum×('b::enum×'c::enum)) ell2 CL _)"
  have "one_mat (CARD('a)*CARD('b)*CARD('c)) = mat_of_cblinfun (?assoc oCL ?assoc')"
    by (simp add: mult.assoc mat_of_cblinfun_id)
  also have  = mat_of_cblinfun ?assoc * mat_of_cblinfun ?assoc'
    using mat_of_cblinfun_compose by blast
  also have  = mat_of_cblinfun ?assoc * one_mat (CARD('a)*CARD('b)*CARD('c))
    by simp
  also have  = mat_of_cblinfun ?assoc
    apply (rule right_mult_one_mat')
    by (simp)
  finally show ?thesis
    by simp
qed

end

Theory Teleport

section Quantum teleportation

theory Teleport
  imports 
    QHoare
    Real_Impl.Real_Impl
    "HOL-Library.Code_Target_Numeral"
    Finite_Tensor_Product_Matrices
    "HOL-Library.Word"
begin

hide_const (open) Finite_Cartesian_Product.vec
hide_type (open) Finite_Cartesian_Product.vec
hide_const (open) Finite_Cartesian_Product.mat
hide_const (open) Finite_Cartesian_Product.row
hide_const (open) Finite_Cartesian_Product.column
no_notation Group.mult (infixl "ı" 70)
no_notation Order.top ("ı")
unbundle no_vec_syntax
unbundle no_inner_syntax


locale teleport_locale = qhoare "TYPE('mem::finite)" +
  fixes X :: "bit update  'mem::finite update"
    and Φ :: "(bit*bit) update  'mem update"
    and A :: "'atype::finite update  'mem update"
    and B :: "'btype::finite update  'mem update"
  assumes compat[register]: "mutually compatible (X,Φ,A,B)"
begin

abbreviation "Φ1  Φ  Fst"
abbreviation "Φ2  Φ  Snd"
abbreviation "XΦ2  (X;Φ2)"
abbreviation "XΦ1  (X;Φ1)"
abbreviation "  (X;Φ)"
abbreviation "XAB  ((X;A); B)"
abbreviation "AB  (A;B)"
abbreviation "Φ2AB  ((Φ o Snd; A); B)"

definition "teleport a b = [
    apply CNOT XΦ1,
    apply hadamard X,
    ifthen Φ1 a,
    ifthen X b, 
    apply (if a=1 then pauliX else id_cblinfun) Φ2,
    apply (if b=1 then pauliZ else id_cblinfun) Φ2
  ]"


lemma Φ_XΦ: Φ a =  (id_cblinfun o a)
  by (auto simp: register_pair_apply)
lemma XΦ1_XΦ: XΦ1 a =  (assoc (a o id_cblinfun))
  apply (subst pair_o_assoc[unfolded o_def, of X Φ1 Φ2, simplified, THEN fun_cong])
  by (auto simp: register_pair_apply)
lemma XΦ2_XΦ: XΦ2 a =  ((id r swap) (assoc (a o id_cblinfun)))
  apply (subst pair_o_tensor[unfolded o_def, THEN fun_cong], simp, simp, simp)
  apply (subst (2) register_Fst_register_Snd[symmetric, of Φ], simp)
  using [[simproc del: compatibility_warn]]
  apply (subst pair_o_swap[unfolded o_def], simp)
  apply (subst pair_o_assoc[unfolded o_def, THEN fun_cong], simp, simp, simp)
  by (auto simp: register_pair_apply)
lemma Φ2_XΦ: Φ2 a =  (id_cblinfun o (id_cblinfun o a))
  by (auto simp: Snd_def register_pair_apply)
lemma X_XΦ: X a =  (a o id_cblinfun)
  by (auto simp: register_pair_apply)
lemma Φ1_XΦ: Φ1 a =  (id_cblinfun o (a o id_cblinfun))
  by (auto simp: Fst_def register_pair_apply)
lemmas to_XΦ = Φ_XΦ XΦ1_XΦ XΦ2_XΦ Φ2_XΦ X_XΦ Φ1_XΦ

lemma X_XΦ1: X a = XΦ1 (a o id_cblinfun)
  by (auto simp: register_pair_apply)
lemmas to_XΦ1 = X_XΦ1

lemma XAB_to_XΦ2_AB: XAB a = (XΦ2;AB) ((swap r id) (assoc' (id_cblinfun o assoc a)))
  by (simp add: pair_o_tensor[unfolded o_def, THEN fun_cong] register_pair_apply
      pair_o_swap[unfolded o_def, THEN fun_cong]
      pair_o_assoc'[unfolded o_def, THEN fun_cong]
      pair_o_assoc[unfolded o_def, THEN fun_cong])

lemma XΦ2_to_XΦ2_AB: XΦ2 a = (XΦ2;AB) (a o id_cblinfun)
  by (simp add: register_pair_apply)

schematic_goal Φ2AB_to_XΦ2_AB: "Φ2AB a = (XΦ2;AB) ?b"
  apply (subst pair_o_assoc'[unfolded o_def, THEN fun_cong])
     apply simp_all[3]
  apply (subst register_pair_apply[where a=id_cblinfun])
   apply simp_all[2]
  apply (subst pair_o_assoc[unfolded o_def, THEN fun_cong])
     apply simp_all[3]
  by simp

lemmas to_XΦ2_AB = XAB_to_XΦ2_AB XΦ2_to_XΦ2_AB Φ2AB_to_XΦ2_AB

lemma teleport:
  assumes [simp]: "norm ψ = 1"
  shows "hoare (XAB =q ψ  Φ =q β00) (teleport a b) (Φ2AB =q ψ)"
proof -
  define XZ :: bit update where "XZ = (if a=1 then (if b=1 then pauliZ oCL pauliX else pauliX) else (if b=1 then pauliZ else id_cblinfun))"

  define pre where "pre = XAB =q ψ"

  define O1 where "O1 = Φ (selfbutter β00)"
  have (XAB =q ψ  Φ =q β00) = O1 *S pre
    unfolding pre_def O1_def EQ_def
    apply (subst compatible_proj_intersect[where R=XAB and S=Φ])
       apply (simp_all add: butterfly_is_Proj)
    apply (subst swap_registers[where R=XAB and S=Φ])
    by (simp_all add: cblinfun_assoc_left(2))

  also
  define O2 where "O2 = XΦ1 CNOT oCL O1"
  have hoare (O1 *S pre) [apply CNOT XΦ1] (O2 *S pre)
    apply (rule hoare_apply) by (simp add: O2_def cblinfun_assoc_left(2))

  also
  define O3 where O3 = X hadamard oCL O2
  have hoare (O2 *S pre) [apply hadamard X] (O3 *S pre)
    apply (rule hoare_apply) by (simp add: O3_def cblinfun_assoc_left(2))

  also
  define O4 where O4 = Φ1 (selfbutterket a) oCL O3
  have hoare (O3 *S pre) [ifthen Φ1 a] (O4 *S pre)
    apply (rule hoare_ifthen) by (simp add: O4_def cblinfun_assoc_left(2))

  also
  define O5 where O5 = X (selfbutterket b) oCL O4
  have hoare (O4 *S pre) [ifthen X b] (O5 *S pre)
    apply (rule hoare_ifthen) by (simp add: O5_def cblinfun_assoc_left(2))

  also
  define O6 where O6 = Φ2 (if a=1 then pauliX else id_cblinfun) oCL O5
  have hoare (O5 *S pre) [apply (if a=1 then pauliX else id_cblinfun) (Φ  Snd)] (O6 *S pre)
    apply (rule hoare_apply) by (auto simp add: O6_def cblinfun_assoc_left(2))

  also
  define O7 where O7 = Φ2 (if b = 1 then pauliZ else id_cblinfun) oCL O6
  have O7: O7 = Φ2 XZ oCL O5
    by (auto simp add: O6_def O7_def XZ_def register_mult lift_cblinfun_comp[OF register_mult])
  have hoare (O6 *S pre) [apply (if b=1 then pauliZ else id_cblinfun) (Φ  Snd)] (O7 *S pre)
    apply (rule hoare_apply) 
    by (auto simp add: O7_def cblinfun_assoc_left(2))

  finally have hoare: hoare (XAB =q ψ  Φ =q β00) (teleport a b) (O7 *S pre)
    by (auto simp add: teleport_def comp_def)

  have O5': "O5 = (1/2) *C Φ2 (XZ*) oCL XΦ2 Uswap oCL Φ (butterfly (ket a s ket b) β00)"
    unfolding O7 O5_def O4_def O3_def O2_def O1_def 
    apply (simp split del: if_split only: to_XΦ register_mult[of ])
    apply (simp split del: if_split add: register_mult[of ] 
                flip: complex_vector.linear_scale
                del: comp_apply)
    apply (rule arg_cong[of _ _ ])
    apply (rule cblinfun_eq_mat_of_cblinfunI)
    apply (simp add: assoc_ell2_sandwich mat_of_cblinfun_tensor_op XZ_def
                     butterfly_def mat_of_cblinfun_compose mat_of_cblinfun_vector_to_cblinfun
                     mat_of_cblinfun_adj vec_of_basis_enum_ket mat_of_cblinfun_id
                     swap_sandwich[abs_def] mat_of_cblinfun_scaleR mat_of_cblinfun_scaleC
                     id_tensor_sandwich vec_of_basis_enum_tensor_state mat_of_cblinfun_cblinfun_apply
                     mat_of_cblinfun_sandwich)
    by normalization

  have [simp]: "unitary XZ"
    unfolding unitary_def unfolding XZ_def apply auto
     apply (metis cblinfun_assoc_left(1) pauliXX pauliZZ cblinfun_compose_id_left)
    by (metis cblinfun_assoc_left(1) pauliXX pauliZZ cblinfun_compose_id_left)

  have O7': "O7 = (1/2) *C XΦ2 Uswap oCL Φ (butterfly (ket a s ket b) β00)"
    unfolding O7 O5'
    by (simp add: cblinfun_compose_assoc[symmetric] register_mult[of Φ2] del: comp_apply)

  have "O7 *S pre = XΦ2 Uswap *S XAB (selfbutter ψ) *S Φ (butterfly (ket (a, b)) β00) *S "
    apply (simp add: O7' pre_def EQ_def cblinfun_compose_image)
    apply (subst lift_cblinfun_comp[OF swap_registers[where R=Φ and S=XAB]], simp)
    by (simp add: cblinfun_assoc_left(2))
  also have   XΦ2 Uswap *S XAB (selfbutter ψ) *S 
    by (simp add: cblinfun_image_mono)
  also have  = (XΦ2;AB) (Uswap o id_cblinfun) *S (XΦ2;AB)
                      ((swap r id) (assoc' (id_cblinfun o assoc (selfbutter ψ)))) *S 
    by (simp add: to_XΦ2_AB)
  also have  = Φ2AB (selfbutter ψ) *S XΦ2 Uswap *S 
    apply (simp add: swap_sandwich sandwich_grow_left to_XΦ2_AB   
        cblinfun_compose_image[symmetric] register_mult)
    by (simp add: sandwich_def cblinfun_compose_assoc[symmetric] comp_tensor_op tensor_op_adjoint)
  also have   Φ2AB =q ψ
    by (simp add: EQ_def cblinfun_image_mono)
  finally have O7 *S pre  Φ2AB =q ψ
    by simp

  with hoare
  show ?thesis
    by (meson basic_trans_rules(31) hoare_def less_eq_ccsubspace.rep_eq)
qed

end


locale concrete_teleport_vars begin

type_synonym a_state = "64 word"
type_synonym b_state = "1000000 word"
type_synonym mem = "a_state * bit * bit * b_state * bit"
type_synonym 'a var = 'a update  mem update

definition A :: "a_state var" where A a = a o id_cblinfun o id_cblinfun o id_cblinfun o id_cblinfun
definition X :: bit var where X a = id_cblinfun o a o id_cblinfun o id_cblinfun o id_cblinfun
definition Φ1 :: bit var where Φ1 a = id_cblinfun o id_cblinfun o a o id_cblinfun o id_cblinfun
definition B :: b_state var where B a = id_cblinfun o id_cblinfun o id_cblinfun o a o id_cblinfun
definition Φ2 :: bit var where Φ2 a = id_cblinfun o id_cblinfun o id_cblinfun o id_cblinfun o a

end


interpretation teleport_concrete:
  concrete_teleport_vars +
  teleport_locale concrete_teleport_vars.X
                  (concrete_teleport_vars.Φ1; concrete_teleport_vars.Φ2)
                  concrete_teleport_vars.A
                  concrete_teleport_vars.B
  apply standard
  using [[simproc del: compatibility_warn]]
  by (auto simp: concrete_teleport_vars.X_def[abs_def]
                 concrete_teleport_vars.Φ1_def[abs_def]
                 concrete_teleport_vars.Φ2_def[abs_def]
                 concrete_teleport_vars.A_def[abs_def]
                 concrete_teleport_vars.B_def[abs_def]
           intro!: compatible3' compatible3)

thm teleport
thm teleport_def

end

Theory Axioms_Complement_Quantum

section Quantum instantiation of complements

theory Axioms_Complement_Quantum
  imports Laws_Quantum Finite_Tensor_Product Quantum_Extra
begin

no_notation m_inv ("invı _" [81] 80)
no_notation Lattice.join (infixl "ı" 65)

typedef ('a::finite,'b::finite) complement_domain = {..< if CARD('b) div CARD('a)  0 then CARD('b) div CARD('a) else 1}
  by auto

instance complement_domain :: (finite, finite) finite
proof intro_classes
  have inj Rep_complement_domain
    by (simp add: Rep_complement_domain_inject inj_on_def)
  moreover have finite (range Rep_complement_domain)
    by (metis finite_lessThan type_definition.Rep_range type_definition_complement_domain)
  ultimately show finite (UNIV :: ('a,'b) complement_domain set)
    using finite_image_iff by blast
qed

lemma CARD_complement_domain: 
  assumes CARD('b::finite) = n * CARD('a::finite)
  shows CARD(('a,'b) complement_domain) = n
proof -
  from assms have n > 0
    by (metis zero_less_card_finite zero_less_mult_pos2)
  have *: inj Rep_complement_domain
    by (simp add: Rep_complement_domain_inject inj_on_def)
  moreover have card (range (Rep_complement_domain :: ('a,'b) complement_domain  _)) = n
    apply (subst type_definition.Rep_range[OF type_definition_complement_domain])
    using assms n > 0 by simp
  ultimately show ?thesis
    by (metis card_image)
qed


lemma register_decomposition:
  fixes Φ :: 'a::finite update  'b::finite update
  assumes [simp]: register Φ
  shows U :: ('a × ('a, 'b) complement_domain) ell2 CL 'b ell2. unitary U  
              (θ. Φ θ = sandwich U (θ o id_cblinfun))
  ― ‹Proof based on @{cite daws21unitalanswer}
proof -
  note [[simproc del: compatibility_warn]]
  fix ξ0 :: 'a

  have [simp]: clinear Φ
    by simp

  define P where P i = Proj (ccspan {ket i}) for i :: 'a
  have P_butter: P i = selfbutterket i for i
    by (simp add: P_def butterfly_eq_proj)

  define P' where P' i = Φ (P i) for i :: 'a
  have proj_P': is_Proj (P' i) for i
    by (simp add: P_def P'_def register_projector)
  have (iUNIV. P i) = id_cblinfun
    using sum_butterfly_ket P_butter by simp
  then have sumP'id: (iUNIV. P' i) = id_cblinfun
    unfolding P'_def 
    apply (subst complex_vector.linear_sum[OF clinear Φ, symmetric])
    by auto

  define S where S i = P' i *S  for i :: 'a
  have P'id: P' i *V ψ = ψ if ψ  space_as_set (S i) for i ψ
    using S_def that proj_P'
    by (metis cblinfun_fixes_range is_Proj_algebraic)

  obtain B0 where finiteB0: finite (B0 i) and cspanB0: cspan (B0 i) = space_as_set (S i) for i
    apply atomize_elim apply (simp flip: all_conj_distrib) apply (rule choice)
    by (meson cfinite_dim_finite_subspace_basis csubspace_space_as_set)

  obtain B where orthoB: is_ortho_set (B i)
    and normalB: b. b  B i  norm b = 1
    and cspanB: cspan (B i) = cspan (B0 i)
    and finiteB: finite (B i) for i
    apply atomize_elim apply (simp flip: all_conj_distrib) apply (rule choice)
    using orthonormal_basis_of_cspan[OF finiteB0] by blast

  from cspanB cspanB0 have cspanB: cspan (B i) = space_as_set (S i) for i
    by simp
  then have ccspanB: ccspan (B i) = S i for i
    by (metis ccspan.rep_eq closure_finite_cspan finiteB space_as_set_inject)
  from orthoB have indepB: cindependent (B i) for i
    by (simp add: Complex_Inner_Product.is_ortho_set_cindependent)

  have orthoBiBj: is_orthogonal x y if x  B i and y  B j and i  j for x y i j
  proof -
    from x  B i obtain x' where x: x = P' i *V x'
      by (metis S_def cblinfun_fixes_range complex_vector.span_base cspanB is_Proj_idempotent proj_P')
    from y  B j obtain y' where y: y = P' j *V y'
      by (metis S_def cblinfun_fixes_range complex_vector.span_base cspanB is_Proj_idempotent proj_P')
    have cinner x y = cinner (P' i *V x') (P' j *V  y')
      using x y by simp
    also have  = cinner (P' j *V P' i *V x') y'
      by (metis cinner_adj_left is_Proj_algebraic proj_P')
    also have  = cinner (Φ (P j oCL P i) *V x') y'
      unfolding P'_def register_mult[OF register Φ, symmetric] by simp
    also have  = cinner (Φ (selfbutterket j oCL selfbutterket i) *V x') y'
      unfolding P_butter by simp
    also have  = cinner (Φ 0 *V x') y'
      by (metis butterfly_comp_butterfly complex_vector.scale_eq_0_iff orthogonal_ket that(3))
    also have  = 0
      by (simp add: complex_vector.linear_0)
    finally show ?thesis
      by -
  qed


  define B' where B' = (iUNIV. B i)

  have P'B: P' i = Proj (ccspan (B i)) for i
    unfolding ccspanB S_def
    using proj_P' Proj_on_own_range'[symmetric] is_Proj_algebraic by blast

  have (iUNIV. P' i) = Proj (ccspan B')
  proof (unfold B'_def, use finite[of UNIV] in induction)
    case empty
    show ?case by auto
  next
    case (insert j M)
    have (iinsert j M. P' i) = P' j + (iM. P' i)
      by (meson insert.hyps(1) insert.hyps(2) sum.insert)
    also have  = Proj (ccspan (B j)) + Proj (ccspan (iM. B i))
      unfolding P'B insert.IH[symmetric] by simp
    also have  = Proj (ccspan (B j  (iM. B i)))
      apply (rule Proj_orthog_ccspan_union[symmetric])
      using orthoBiBj insert.hyps(2) by auto
    also have  = Proj (ccspan (iinsert j M. B i))
      by auto
    finally show ?case
      by simp
  qed

  with sumP'id 
  have ccspanB': ccspan B' = 
    by (metis Proj_range cblinfun_image_id)
  hence cspanB': cspan B' = UNIV
    by (metis B'_def finiteB ccspan.rep_eq finite_UN_I finite_class.finite_UNIV closure_finite_cspan top_ccsubspace.rep_eq)

  from orthoBiBj orthoB have orthoB': is_ortho_set B'
    unfolding B'_def is_ortho_set_def by blast
  then have indepB': cindependent B'
    using is_ortho_set_cindependent by blast
  have cardB': card B' = CARD('b)
    apply (subst complex_vector.dim_span_eq_card_independent[symmetric])
     apply (rule indepB')
    apply (subst cspanB')
    using cdim_UNIV_ell2 by auto

  from orthoBiBj orthoB
  have Bdisj: B i  B j = {} if i  j for i j
    unfolding is_ortho_set_def
    apply auto by (metis cinner_eq_zero_iff that)

  have cardBsame: card (B i) = card (B j) for i j
  proof -
    define Si_to_Sj where Si_to_Sj i j ψ = Φ (butterket j i) *V ψ for i j ψ
    have S2S2S: Si_to_Sj j i (Si_to_Sj i j ψ) = ψ if ψ  space_as_set (S i) for i j ψ
      using that P'id
      by (simp add: Si_to_Sj_def cblinfun_apply_cblinfun_compose[symmetric] register_mult P_butter P'_def)
    also have lin[simp]: clinear (Si_to_Sj i j) for i j
      unfolding Si_to_Sj_def by simp
    have S2S: Si_to_Sj i j x  space_as_set (S j) for i j x
    proof -
      have Si_to_Sj i j x = P' j *V Si_to_Sj i j x
        by (simp add: Si_to_Sj_def cblinfun_apply_cblinfun_compose[symmetric] register_mult P_butter P'_def)
      also have P' j *V Si_to_Sj i j x  space_as_set (S j)
        by (simp add: S_def)
      finally show ?thesis by -
    qed
    have bij: bij_betw (Si_to_Sj i j) (space_as_set (S i)) (space_as_set (S j))
      apply (rule bij_betwI[where g=Si_to_Sj j i])
      using S2S S2S2S by (auto intro!: funcsetI)
    have cdim (space_as_set (S i)) = cdim (space_as_set (S j))
      using lin apply (rule isomorphic_equal_cdim[where f=Si_to_Sj i j])
      using bij apply (auto simp: bij_betw_def)
      by (metis complex_vector.span_span cspanB)
    then show ?thesis
      by (metis complex_vector.dim_span_eq_card_independent cspanB indepB)
  qed

  have CARD'b: CARD('b) = card (B ξ0) * CARD('a)
  proof -
    have CARD('b) = card B'
      using cardB' by simp
    also have  = (iUNIV. card (B i))
      unfolding B'_def apply (rule card_UN_disjoint)
      using finiteB Bdisj by auto
    also have  = ((i::'a)UNIV. card (B ξ0))
      using cardBsame by metis
    also have  = card (B ξ0) * CARD('a)
      by auto
    finally show ?thesis by -
  qed

  obtain f where bij_f: bij_betw f (UNIV::('a,'b) complement_domain set) (B ξ0)
    apply atomize_elim apply (rule finite_same_card_bij)
    using finiteB CARD_complement_domain[OF CARD'b] by auto

  define u where u = (λ(ξ,α). Φ (butterket ξ ξ0) *V f α) for ξ :: 'a and α :: ('a,'b) complement_domain
  obtain U where Uapply: U *V ket ξα = u ξα for ξα
    apply atomize_elim
    apply (rule exI[of _ cblinfun_extension (range ket) (λk. u (inv ket k))])
    apply (subst cblinfun_extension_apply)
      apply (rule cblinfun_extension_exists_finite_dim)
    by (auto simp add: inj_ket cindependent_ket)

  define eqa where eqa a b = (if a = b then 1 else 0 :: complex) for a b :: 'a
  define eqc where eqc a b = (if a = b then 1 else 0 :: complex) for a b :: ('a,'b) complement_domain
  define eqac where eqac a b = (if a = b then 1 else 0 :: complex) for a b :: 'a * ('a,'b) complement_domain

  have cinner (U *V ket ξα) (U *V ket ξ'α') = eqac ξα ξ'α' for ξα ξ'α'
  proof -
    obtain ξ α ξ' α' where ξα: ξα = (ξ,α) and ξ'α': ξ'α' = (ξ',α')
      apply atomize_elim by auto
    have cinner (U *V ket (ξ,α)) (U *V ket (ξ', α')) = cinner (Φ (butterket ξ ξ0) *V f α) (Φ (butterket ξ' ξ0) *V f α')
      unfolding Uapply u_def by simp
    also have  = cinner ((Φ (butterket ξ' ξ0))* *V Φ (butterket ξ ξ0) *V f α) (f α')
      by (simp add: cinner_adj_left)
    also have  = cinner (Φ (butterket ξ' ξ0 *) *V Φ (butterket ξ ξ0) *V f α) (f α')
      by (metis (no_types, lifting) assms register_def)
    also have  = cinner (Φ (butterket ξ0 ξ' oCL butterket ξ ξ0) *V f α) (f α')
      by (simp add: register_mult cblinfun_apply_cblinfun_compose[symmetric])
    also have  = cinner (Φ (eqa ξ' ξ *C selfbutterket ξ0) *V f α) (f α')
      apply simp by (metis eqa_def cinner_ket)
    also have  = eqa ξ' ξ * cinner (Φ (selfbutterket ξ0) *V f α) (f α')
      by (smt (verit, ccfv_threshold) clinear Φ eqa_def cblinfun.scaleC_left cinner_commute 
              cinner_scaleC_left cinner_zero_right complex_cnj_one complex_vector.linear_scale)
    also have  = eqa ξ' ξ * cinner (P' ξ0 *V f α) (f α')
      using P_butter P'_def by simp
    also have  = eqa ξ' ξ * cinner (f α) (f α')
      apply (subst P'id)
       apply (metis bij_betw_imp_surj_on bij_f complex_vector.span_base cspanB rangeI)
      by simp
    also have  = eqa ξ' ξ * eqc α α'
      using bij_f orthoB normalB unfolding is_ortho_set_def eqc_def apply auto
       apply (metis bij_betw_imp_surj_on cnorm_eq_1 rangeI)
      by (smt (z3) bij_betw_iff_bijections iso_tuple_UNIV_I)
    finally show ?thesis
      by (simp add: eqa_def eqac_def eqc_def ξ'α' ξα)
  qed
  then have isometry U
    apply (rule_tac orthogonal_on_basis_is_isometry[where B=range ket])
    using eqac_def by auto

  have U* oCL Φ (butterket ξ η) oCL U = butterket ξ η o id_cblinfun for ξ η
  proof (rule equal_ket, rename_tac ξ1α)
    fix ξ1α obtain ξ1 :: 'a and α :: ('a,'b) complement_domain where ξ1α: ξ1α = (ξ1,α) 
      apply atomize_elim by auto
    have (U* oCL Φ (butterket ξ η) oCL U) *V ket ξ1α = U* *V Φ (butterket ξ η) *V Φ (butterket ξ1 ξ0) *V f α
      unfolding cblinfun_apply_cblinfun_compose ξ1α Uapply u_def by simp
    also have  = U* *V Φ (butterket ξ η oCL butterket ξ1 ξ0) *V f α
      by (metis (no_types, lifting) assms butterfly_comp_butterfly lift_cblinfun_comp(4) register_mult)
    also have  = U* *V Φ (eqa η ξ1 *C butterket ξ ξ0) *V f α
      by (simp add: eqa_def cinner_ket)
    also have  = eqa η ξ1 *C U* *V Φ (butterket ξ ξ0) *V f α
      by (simp add: complex_vector.linear_scale)
    also have  = eqa η ξ1 *C U* *V U *V ket (ξ, α)
      unfolding Uapply u_def by simp
    also from isometry U have  = eqa η ξ1 *C ket (ξ, α)
      unfolding cblinfun_apply_cblinfun_compose[symmetric] by simp
    also have  = (butterket ξ η *V ket ξ1) s ket α
      by (simp add: eqa_def tensor_ell2_scaleC1)
    also have  = (butterket ξ η o id_cblinfun) *V ket ξ1α
      by (simp add: ξ1α tensor_op_ket)
    finally show (U* oCL Φ (butterket ξ η) oCL U) *V ket ξ1α = (butterket ξ η o id_cblinfun) *V ket ξ1α
      by -
  qed
  then have 1: U* oCL Φ θ oCL U = θ o id_cblinfun for θ
    apply (rule_tac clinear_eq_butterfly_ketI[THEN fun_cong, where x=θ])
    by (auto intro!: clinearI simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose complex_vector.linear_add complex_vector.linear_scale)

  have unitary U
  proof -
    have Φ (butterket ξ ξ1) *S   U *S  for ξ ξ1
    proof -
      have *: Φ (butterket ξ ξ0) *V b  space_as_set (U *S ) if b  B ξ0 for b
        apply (subst asm_rl[of Φ (butterket ξ ξ0) *V b = u (ξ, inv f b)])
         apply (simp add: u_def, metis bij_betw_inv_into_right bij_f that)
        by (metis Uapply cblinfun_apply_in_image)

      have Φ (butterket ξ ξ1) *S  = Φ (butterket ξ ξ0) *S Φ (butterket ξ0 ξ0) *S Φ (butterket ξ0 ξ1) *S 
        unfolding cblinfun_compose_image[symmetric] register_mult[OF assms]
        by simp
      also have   Φ (butterket ξ ξ0) *S Φ (butterket ξ0 ξ0) *S 
        by (meson cblinfun_image_mono top_greatest)
      also have  = Φ (butterket ξ ξ0) *S S ξ0
        by (simp add: S_def P'_def P_butter)
      also have  = Φ (butterket ξ ξ0) *S ccspan (B ξ0)
        by (simp add: ccspanB)
      also have  = ccspan (Φ (butterket ξ ξ0) ` B ξ0)
        by (meson cblinfun_image_ccspan)
      also have   U *S 
        by (rule ccspan_leqI, use * in auto)
      finally show ?thesis by -
    qed
    moreover have Φ id_cblinfun *S   (SUP ξUNIV. Φ (selfbutterket ξ) *S )
      unfolding sum_butterfly_ket[symmetric]
      apply (subst complex_vector.linear_sum, simp)
      by (rule cblinfun_sum_image_distr)
    ultimately have Φ id_cblinfun *S   U *S 
      apply auto by (meson SUP_le_iff order.trans)
    then have U *S  = 
      apply auto
      using top.extremum_unique by blast
    with isometry U show unitary U
      by (rule surj_isometry_is_unitary)
  qed

  have Φ θ = U oCL (θ o id_cblinfun) oCL U* for θ
  proof -
    from unitary U
    have Φ θ = (U oCL U*) oCL Φ θ oCL (U oCL U*)
      by simp
    also have  = U oCL (U*  oCL Φ θ oCL U) oCL U*
      by (simp add: cblinfun_assoc_left)
    also have  = U oCL (θ o id_cblinfun) oCL U*
      using 1 by simp
    finally show ?thesis
      by -
  qed

  with unitary U show ?thesis
    by (auto simp: sandwich_def)
qed

lemma register_decomposition_converse: 
  assumes unitary U
  shows register (λx. sandwich U (id_cblinfun o x))
  using _ unitary_sandwich_register apply (rule register_comp[unfolded o_def])
  using assms by auto


lemma register_inj: inj F if register F
proof -
  obtain U :: ('a × ('a, 'b) complement_domain) ell2 CL 'b ell2
    where unitary U and F: F a = sandwich U (a o id_cblinfun) for a
    apply atomize_elim using register F by (rule register_decomposition)
  have inj (sandwich U)
    by (smt (verit, best) unitary U cblinfun_assoc_left inj_onI sandwich_def cblinfun_compose_id_right cblinfun_compose_id_left unitary_def)
  moreover have inj (λa::'a::finite ell2 CL _. a o id_cblinfun)
    by (rule inj_tensor_left, simp)
  ultimately show inj F
    unfolding F
    by (smt (z3) inj_def) 
qed

lemma iso_register_decomposition:
  assumes [simp]: iso_register F
  shows U. unitary U  F = sandwich U
proof -
  have [simp]: register F
    using assms iso_register_is_register by blast 

  let ?ida = id_cblinfun :: ('a, 'b) complement_domain ell2 CL _

  from register_decomposition[OF register F]
  obtain V :: ('a × ('a, 'b) complement_domain) ell2 CL 'b ell2 where unitary V
    and FV: F θ = sandwich V (θ o ?ida) for θ
    by auto

  have surj F
    by (meson assms iso_register_inv_comp2 surj_iff)
  have surj_tensor: surj (λa::'a ell2 CL 'a ell2. a o ?ida)
    apply (rule surj_from_comp[where g=sandwich V])
    using surj F apply (auto simp: FV)
    by (meson unitary V register_inj unitary_sandwich_register)
  then obtain a :: 'a ell2 CL _ 
    where a: a o ?ida = selfbutterket undefined o selfbutterket undefined
    by (smt (verit, best) surjD)

  then have a  0
    apply auto
    by (metis butterfly_apply cblinfun.zero_left complex_vector.scale_eq_0_iff ket_nonzero orthogonal_ket)

  obtain γ where γ: ?ida = γ *C selfbutterket undefined
    apply atomize_elim
    using a a  0 by (rule tensor_op_almost_injective)
  then have ?ida (ket undefined) = γ *C (selfbutterket undefined *V ket undefined)
    by (simp add: id_cblinfun = γ *C selfbutterket undefined scaleC_cblinfun.rep_eq)
  then have ket undefined = γ *C ket undefined
    by (metis butterfly_apply cinner_scaleC_right id_cblinfun_apply cinner_ket_same mult.right_neutral scaleC_one)
  then have γ = 1
    by (smt (z3) γ butterfly_apply butterfly_scaleC_left cblinfun_id_cblinfun_apply complex_vector.scale_cancel_right cinner_ket_same ket_nonzero)

  define T U where T = CBlinfun (λψ. ψ s ket undefined) and U = V oCL T
  have T: T ψ = ψ s ket undefined for ψ
    unfolding T_def
    apply (subst bounded_clinear_CBlinfun_apply)
    by (auto intro!: bounded_clinear_finite_dim clinear_tensor_ell22)
  have sandwich_T: sandwich T a = a o ?ida for a
    apply (rule fun_cong[where x=a])
    apply (rule clinear_eq_butterfly_ketI)
      apply auto
    by (metis (no_types, opaque_lifting) Misc.sandwich_def T γ γ = 1 adj_cblinfun_compose butterfly_adjoint cblinfun_comp_butterfly scaleC_one tensor_butterfly)

  have F (butterfly x y) = V oCL (butterfly x y o ?ida) oCL V* for x y
    by (simp add: Misc.sandwich_def FV)
  also have  x y = V oCL (butterfly (T x) (T y)) oCL V* for x y
    by (simp add: T γ γ = 1)
  also have  x y = U oCL (butterfly x y) oCL U* for x y
    by (simp add: U_def butterfly_comp_cblinfun cblinfun_comp_butterfly)
  finally have F_rep:  F a = U oCL a oCL U* for a
    apply (rule_tac fun_cong[where x=a])
    apply (rule_tac clinear_eq_butterfly_ketI)
      apply auto
    by (metis (no_types, lifting) cblinfun_apply_clinear clinear_iff sandwich_apply)

  have isometry T
    apply (rule orthogonal_on_basis_is_isometry[where B=range ket])
    by (auto simp: T)
  moreover have T *S  = 
  proof -
    have 1: φ s ξ  range ((*V) T) for φ ξ
    proof -
      have T *V (cinner (ket undefined) ξ *C φ) = φ s (cinner (ket undefined) ξ *C ket undefined)
        by (simp add: T tensor_ell2_scaleC2)
      also have  = φ s (selfbutterket undefined *V ξ)
        by simp
      also have  = φ s (?ida *V ξ)
        by (simp add: γ γ = 1)
      also have  = φ s ξ
        by simp
      finally show ?thesis
        by (metis range_eqI)
    qed

    have   ccspan {ket x | x. True}
      by (simp add: full_SetCompr_eq)
    also have   ccspan {φ s ξ | φ ξ. True}
      apply (rule ccspan_mono)
      by (auto simp flip: tensor_ell2_ket)
    also from 1 have   ccspan (range ((*V) T))
      by (auto intro!: ccspan_mono)
    also have  = T *S 
      by (metis (mono_tags, opaque_lifting) calculation cblinfun_image_ccspan cblinfun_image_mono eq_iff top_greatest)
    finally show T *S  = 
      using top.extremum_uniqueI by blast
  qed

  ultimately have unitary T
    by (rule surj_isometry_is_unitary)
  then have unitary U
    by (simp add: U_def unitary V)

  from F_rep unitary U show ?thesis
    by (auto simp: sandwich_def[abs_def])
qed

lemma complement_exists:
  fixes F :: 'a::finite update  'b::finite update
  assumes register F
  shows G :: ('a, 'b) complement_domain update  'b update. compatible F G  iso_register (F;G)
proof -
  note [[simproc del: Laws_Quantum.compatibility_warn]]
  obtain U :: ('a × ('a, 'b) complement_domain) ell2 CL 'b ell2
    where [simp]: "unitary U" and F: F a = sandwich U (a o id_cblinfun) for a
    apply atomize_elim using assms by (rule register_decomposition)
  define G :: (('a, 'b) complement_domain) update  'b update where G b = sandwich U (id_cblinfun o b) for b
  have [simp]: register G
    unfolding G_def apply (rule register_decomposition_converse) by simp
  have F a oCL G b = G b oCL F a for a b
  proof -
    have F a oCL G b = sandwich U (a o b)
      apply (auto simp: F G_def sandwich_def)
      by (metis (no_types, lifting) unitary U isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
    moreover have G b oCL F a = sandwich U (a o b)
      apply (auto simp: F G_def sandwich_def)
      by (metis (no_types, lifting) unitary U isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
    ultimately show ?thesis by simp
  qed
  then have [simp]: compatible F G
    by (auto simp: compatible_def register F register G)
  moreover have iso_register (F;G)
  proof -
    have (F;G) (a o b) = sandwich U (a o b) for a b
      apply (auto simp: register_pair_apply F G_def sandwich_def)
      by (metis (no_types, lifting) unitary U isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
    then have FG: (F;G) = sandwich U
      apply (rule tensor_extensionality[rotated -1])
      by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right clinearI)
    define I where I = sandwich (U*) for x
    have [simp]: register I
      by (simp add: I_def unitary_sandwich_register)
    have I o (F;G) = id and FGI: (F;G) o I = id
       apply (auto intro!:ext simp: I_def[abs_def] FG sandwich_def)
       apply (metis (no_types, opaque_lifting) unitary U isometryD cblinfun_assoc_left(1) cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
      by (metis (no_types, lifting) unitary U cblinfun_assoc_left(1) cblinfun_compose_id_left cblinfun_compose_id_right unitaryD2)
    then show iso_register (F;G)
      by (auto intro!: iso_registerI)
  qed
  ultimately show ?thesis
    apply (rule_tac exI[of _ G]) by (auto)
qed

definition commutant F = {x. yF. x oCL y = y oCL x}

lemma commutant_exchange:
  fixes F :: 'a::finite update  'b::finite update
  assumes iso_register F
  shows commutant (F ` X) = F ` commutant X
proof (rule Set.set_eqI)
  fix x :: 'b update
  from assms
  obtain G where F o G = id and G o F = id and [simp]: register G
    using iso_register_def by blast
  from assms have [simp]: register F
    using iso_register_def by blast
  have x  commutant (F ` X)  (y  F ` X. x oCL y = y oCL x)
    by (simp add: commutant_def)
  also have   (y  F ` X. G x oCL G y = G y oCL G x)
    by (metis (no_types, opaque_lifting) F  G = id G o F = id register G comp_def eq_id_iff register_def)
  also have   (y  X. G x oCL y = y oCL G x)
    by (simp add: G  F = id pointfree_idE)
  also have   G x  commutant X
    by (simp add: commutant_def)
  also have   x  F ` commutant X
    by (metis (no_types, opaque_lifting) G  F = id F  G = id image_iff pointfree_idE)
  finally show x  commutant (F ` X)  x  F ` commutant X
    by -
qed

lemma commutant_tensor1: commutant (range (λa. a o id_cblinfun)) = range (λb. id_cblinfun o b)
proof (rule Set.set_eqI, rule iffI)
  fix x :: ('a × 'b) ell2 CL ('a × 'b) ell2
  fix γ :: 'a
  assume x  commutant (range (λa. a o id_cblinfun))
  then have comm: (a o id_cblinfun) *V x *V ψ = x *V (a o id_cblinfun) *V ψ for a ψ
    by (metis (mono_tags, lifting) commutant_def mem_Collect_eq rangeI cblinfun_apply_cblinfun_compose)

  obtain x' where x': cinner (ket j) (x' *V ket l) = cinner (ket (γ,j)) (x *V ket (γ,l)) for j l
  proof atomize_elim
    obtain ψ where ψ: cinner (ket j) (ψ l) = cinner (ket (γ, j)) (x *V ket (γ, l)) for l j
      apply (atomize_elim, rule choice, rule allI)
      apply (rule_tac x=Abs_ell2 (λj. cinner (ket (γ, j)) (x *V ket (γ, l))) in exI)
      by (simp add: cinner_ket_left Abs_ell2_inverse)
    obtain x' where x' *V ket l = ψ l for l
      apply atomize_elim
      apply (rule exI[of _ cblinfun_extension (range ket) (λl. ψ (inv ket l))])
      apply (subst cblinfun_extension_apply)
        apply (rule cblinfun_extension_exists_finite_dim)
      by (auto simp add: inj_ket cindependent_ket)
    with ψ have cinner (ket j) (x' *V ket l) = cinner (ket (γ, j)) (x *V ket (γ, l)) for j l
      by auto
    then show x'. j l. cinner (ket j) (x' *V ket l) = cinner (ket (γ, j)) (x *V ket (γ, l))
      by auto
  qed

  have cinner (ket (i,j)) (x *V ket (k,l)) = cinner (ket (i,j)) ((id_cblinfun o x') *V ket (k,l)) for i j k l
  proof -
    have cinner (ket (i,j)) (x *V ket (k,l))
        = cinner ((butterket i γ o id_cblinfun) *V ket (γ,j)) (x *V (butterket k γ o id_cblinfun) *V ket (γ,l))
      by (auto simp: tensor_op_ket)
    also have  = cinner (ket (γ,j)) ((butterket γ i o id_cblinfun) *V x *V (butterket k γ o id_cblinfun) *V ket (γ,l))
      by (metis (no_types, lifting) cinner_adj_left butterfly_adjoint id_cblinfun_adjoint tensor_op_adjoint)
    also have  = cinner (ket (γ,j)) (x *V (butterket γ i o id_cblinfun oCL butterket k γ o id_cblinfun) *V ket (γ,l))
      unfolding comm by (simp add: cblinfun_apply_cblinfun_compose)
    also have  = cinner (ket i) (ket k) * cinner (ket (γ,j)) (x *V ket (γ,l))
      by (simp add: comp_tensor_op tensor_op_ket tensor_op_scaleC_left)
    also have  = cinner (ket i) (ket k) * cinner (ket j) (x' *V ket l)
      by (simp add: x')
    also have  = cinner (ket (i,j)) ((id_cblinfun o x') *V ket (k,l))
      apply (simp add: tensor_op_ket)
      by (simp flip: tensor_ell2_ket)
    finally show ?thesis by -
  qed
  then have x = (id_cblinfun o x')
    by (auto intro!: equal_ket cinner_ket_eqI)
  then show x  range (λb. id_cblinfun o b)
    by auto
next
  fix x :: ('a × 'b) ell2 CL ('a × 'b) ell2
  assume x  range (λb. id_cblinfun o b)
  then obtain b where x: x = id_cblinfun o b
    by auto
  then show x  commutant (range (λa. a o id_cblinfun))
    by (auto simp: x commutant_def comp_tensor_op)
qed

lemma complement_range:
  assumes [simp]: compatible F G and [simp]: iso_register (F;G)
  shows range G = commutant (range F)
proof -
  have [simp]: register F register G
    using assms compatible_def by metis+
  have [simp]: (F;G) (a o b) = F a oCL G b for a b
    using Laws_Quantum.register_pair_apply assms by blast
  have [simp]: range F = (F;G) ` range (λa. a o id_cblinfun)
    by force
  have [simp]: range G = (F;G) ` range (λb. id_cblinfun o b)
    by force
  show range G = commutant (range F)
    by (simp add: commutant_exchange commutant_tensor1)
qed

lemma same_range_equivalent:
  fixes F :: 'a::finite update  'c::finite update and G :: 'b::finite update  'c::finite update
  assumes [simp]: register F and [simp]: register G
  assumes range F = range G
  shows equivalent_registers F G
proof -
  have G_rangeF[simp]: G x  range F for x
    by (simp add: assms)
  have F_rangeG[simp]: F x  range G for x
    by (simp add: assms(3)[symmetric])
  have [simp]: inj F and [simp]: inj G
    by (simp_all add: register_inj)
  have [simp]: clinear F clinear G
    by simp_all
  define I J where I x = inv F (G x) and J y = inv G (F y) for x y
  have addI: I (x + y) = I x + I y for x y
    unfolding I_def
    apply (rule injD[OF inj F])
    apply (subst complex_vector.linear_add[OF clinear F])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    by (simp add: complex_vector.linear_add)
  have addJ: J (x + y) = J x + J y for x y
    unfolding J_def
    apply (rule injD[OF inj G])
    apply (subst complex_vector.linear_add[OF clinear G])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    by (simp add: complex_vector.linear_add)
  have scaleI: I (r *C x) = r *C I x for r x
    unfolding I_def
    apply (rule injD[OF inj F])
    apply (subst complex_vector.linear_scale[OF clinear F])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    by (simp add: complex_vector.linear_scale)
  have scaleJ: J (r *C x) = r *C J x for r x
    unfolding J_def
    apply (rule injD[OF inj G])
    apply (subst complex_vector.linear_scale[OF clinear G])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    by (simp add: complex_vector.linear_scale)
  have unitalI: I id_cblinfun = id_cblinfun
    unfolding I_def
    apply (rule injD[OF inj F])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F])
     apply auto
    by (metis register_of_id G_rangeF assms(2))
  have unitalJ: J id_cblinfun = id_cblinfun
    unfolding J_def
    apply (rule injD[OF inj G])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G])
     apply auto
    by (metis register_of_id F_rangeG assms(1))
  have multI: I (a oCL b) = I a oCL I b for a b
    unfolding I_def
    apply (rule injD[OF inj F])
    apply (subst register_mult[symmetric, OF register F])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    by (simp add: register_mult)
  have multJ: J (a oCL b) = J a oCL J b for a b
    unfolding J_def
    apply (rule injD[OF inj G])
    apply (subst register_mult[symmetric, OF register G])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    by (simp add: register_mult)
  have adjI: I (a*) = (I a)* for a
    unfolding I_def
    apply (rule injD[OF inj F])
    apply (subst register_adjoint[OF register F])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    using assms(2) register_adjoint by blast
  have adjJ: J (a*) = (J a)* for a
    unfolding J_def
    apply (rule injD[OF inj G])
    apply (subst register_adjoint[OF register G])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    using assms(1) register_adjoint by blast

  from addI scaleI unitalI multI adjI
  have register I
    unfolding register_def by (auto intro!: clinearI)
  from addJ scaleJ unitalJ multJ adjJ
  have register J
    unfolding register_def by (auto intro!: clinearI)

  have I o J = id
    unfolding I_def J_def o_def
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)
    apply (subst Hilbert_Choice.inv_f_f[OF inj F])
    by auto
  have J o I = id
    unfolding I_def J_def o_def
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)
    apply (subst Hilbert_Choice.inv_f_f[OF inj G])
    by auto

  from I o J = id J o I = id register I register J
  have iso_register I
    using iso_register_def by blast

  have F o I = G
    unfolding I_def o_def
    by (subst Hilbert_Choice.f_inv_into_f[where f=F], auto)

  with iso_register I show ?thesis
    unfolding equivalent_registers_def by auto
qed

lemma complement_unique:
  assumes "compatible F G" and iso_register (F;G)
  assumes "compatible F H" and iso_register (F;H)
  shows equivalent_registers G H
  by (metis assms compatible_def complement_range same_range_equivalent)

end

Theory Laws_Complement_Quantum

(*
 * This is an autogenerated file. Do not edit.
 * The original is Laws_Complement.thy. It was converted using instantiate_laws.py.
 *)

section Generic laws about complements, instantiated quantumly

theory Laws_Complement_Quantum
  imports Laws_Quantum Axioms_Complement_Quantum
begin

notation cblinfun_compose (infixl "*u" 55)
notation tensor_op (infixr "u" 70)

definition complements F G  compatible F G  iso_register (F;G)

lemma complementsI: compatible F G  iso_register (F;G)  complements F G
  using complements_def by blast

lemma complements_sym: complements G F if complements F G
proof (rule complementsI)
  show [simp]: compatible G F
    using compatible_sym complements_def that by blast
  from that have iso_register (F;G)
    by (meson complements_def)
  then obtain I where [simp]: register I and (F;G) o I = id and I o (F;G) = id
    using iso_register_def by blast
  have register (swap o I)
    using register I register_comp register_swap by blast
  moreover have (G;F) o (swap o I) = id
    by (simp add: (F;G)  I = id rewriteL_comp_comp)
  moreover have (swap o I) o (G;F) = id
    by (metis (no_types, opaque_lifting) swap_swap I  (F;G) = id calculation(2) comp_def eq_id_iff)
  ultimately show iso_register (G;F)
    using compatible G F iso_register_def pair_is_register by blast
qed

definition complement :: ('a::finite update  'b::finite update)  (('a,'b) complement_domain update  'b update) where
  complement F = (SOME G :: ('a, 'b) complement_domain update  'b update. compatible F G  iso_register (F;G))

lemma register_complement[simp]: register (complement F) if register F
  using complement_exists[OF that]
  by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)

lemma complement_is_complement:
  assumes register F
  shows complements F (complement F)
  using complement_exists[OF assms] unfolding complements_def
  by (metis (mono_tags, lifting) complement_def some_eq_imp)

lemma complement_unique:
  assumes complements F G
  shows equivalent_registers G (complement F)
  apply (rule complement_unique[where F=F])
  using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+

lemma compatible_complement[simp]: register F  compatible F (complement F)
  using complement_is_complement complements_def by blast

lemma complements_register_tensor:
  assumes [simp]: register F register G
  shows complements (F r G) (complement F r complement G)
proof (rule complementsI)
  have sep4: separating TYPE('z::finite) {(a u b) u (c u d) |a b c d. True}
    apply (rule separating_tensor'[where A={(a u b) |a b. True} and B={(c u d) |c d. True}])
      apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
     apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
    by auto
  show compat: compatible (F r G) (complement F r complement G)
    by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
  let ?reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))
  have [simp]: register ?reorder
    by auto
  have [simp]: ?reorder ((a u b) u (c u d)) = ((a u c) u (b u d)) 
    for a::'t::finite update and b::'u::finite update and c::'v::finite update and d::'w::finite update
    by (simp add: register_pair_apply Fst_def Snd_def comp_tensor_op)
  have [simp]: iso_register ?reorder
    apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
     apply (rule register_eqI[OF sep4]) apply auto[3]
    apply (rule register_eqI[OF sep4]) by auto
  have (F r G; complement F r complement G) = ((F; complement F) r (G; complement G)) o ?reorder
    apply (rule register_eqI[OF sep4])
    by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
        simp: compat register_pair_apply comp_tensor_op)
  moreover have iso_register 
    apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
    using assms complement_is_complement complements_def by blast+
  ultimately show iso_register (F r G;complement F r complement G)
    by simp
qed

definition is_unit_register where
  is_unit_register U  complements U id

lemma register_unit_register[simp]: is_unit_register U  register U
  by (simp add: compatible_def complements_def is_unit_register_def)

lemma unit_register_compatible[simp]: compatible U X if is_unit_register U register X
  by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))

lemma unit_register_compatible'[simp]: compatible X U if is_unit_register U register X
  using compatible_sym that(1) that(2) unit_register_compatible by blast

lemma compatible_complement_left[simp]: register X  compatible (complement X) X
  using compatible_sym complement_is_complement complements_def by blast

lemma compatible_complement_right[simp]: register X  compatible X (complement X)
  using complement_is_complement complements_def by blast

lemma unit_register_pair[simp]: equivalent_registers X (U; X) if [simp]: is_unit_register U register X
proof -
  have equivalent_registers id (U; id)
    using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
  also have equivalent_registers  (U; (X; complement X))
    apply (rule equivalent_registers_pair_right)
     apply (auto intro!: unit_register_compatible)
    using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
  also have equivalent_registers  ((U; X); complement X)
    apply (rule equivalent_registers_assoc)
    by auto
  finally have complements (U; X) (complement X)
    by (auto simp: equivalent_registers_def complements_def)
  moreover have equivalent_registers (X; complement X) id
    by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
  ultimately show ?thesis
    by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
qed

lemma unit_register_compose_left:
  assumes [simp]: is_unit_register U
  assumes [simp]: register A
  shows is_unit_register (A o U)
proof -
  have compatible (A o U) (A; complement A)
    apply (auto intro!: compatible3')
    by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
  then have compat[simp]: compatible (A o U) id
    by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
  have equivalent_registers (A o U; id) (A o U; (A; complement A))
    apply (auto intro!: equivalent_registers_pair_right)
    using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
  also have equivalent_registers  ((A o U; A o id); complement A)
    apply auto
    by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
  also have equivalent_registers  (A o (U; id); complement A)
    by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
  also have equivalent_registers  (A o id; complement A)
    apply (intro equivalent_registers_pair_left equivalent_registers_comp)
      apply (auto simp: assms)
    using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
  also have equivalent_registers  id
    by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
  finally show ?thesis
    using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
qed

lemma unit_register_compose_right:
  assumes [simp]: is_unit_register U
  assumes [simp]: iso_register A
  shows is_unit_register (U o A)
proof (unfold is_unit_register_def, rule complementsI)
  show compatible (U  A) id
    by (simp add: iso_register_is_register)
  have 1: iso_register ((U;id)  A r id)
    by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
  have 2: id  ((U;id)  A r id) = (U  A;id)
    by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
  show iso_register (U  A;id)
    using 1 2 by auto
qed

lemma unit_register_unique:
  assumes is_unit_register F
  assumes is_unit_register G
  shows equivalent_registers F G
proof -
  have complements F id complements G id
    using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
  then show ?thesis
    by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
qed

lemma unit_register_domains_isomorphic:
  fixes F :: 'a::finite update  'c::finite update
  fixes G :: 'b::finite update  'd::finite update
  assumes is_unit_register F
  assumes is_unit_register G
  shows I :: 'a update  'b update. iso_register I
proof -
  have is_unit_register ((λd. tensor_op id_cblinfun d) o G)
    by (simp add: assms(2) unit_register_compose_left)
  moreover have is_unit_register ((λc. tensor_op c id_cblinfun) o F)
    using assms(1) register_tensor_left unit_register_compose_left by blast
  ultimately have equivalent_registers ((λd. tensor_op id_cblinfun d) o G) ((λc. tensor_op c id_cblinfun) o F)
    using unit_register_unique by blast
  then show ?thesis
    unfolding equivalent_registers_def by auto
qed


lemma id_complement_is_unit_register[simp]: is_unit_register (complement id)
  by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)

type_synonym unit_register_domain = (unit, unit) complement_domain
definition unit_register :: unit_register_domain update  'a::finite update where unit_register = (SOME U. is_unit_register U)

lemma unit_register_is_unit_register[simp]: is_unit_register (unit_register :: unit_register_domain update  'a::finite update)
proof -
  let ?U0 = complement id :: unit_register_domain update  unit update
  let ?U1 = complement id :: ('a, 'a) complement_domain update  'a update
  have is_unit_register ?U0 is_unit_register ?U1
    by auto
  then obtain I :: unit_register_domain update  ('a, 'a) complement_domain update where iso_register I
    apply atomize_elim by (rule unit_register_domains_isomorphic)
  with is_unit_register ?U1 have is_unit_register (?U1 o I)
    by (rule unit_register_compose_right)
  then show ?thesis
    by (metis someI_ex unit_register_def)
qed

lemma unit_register_domain_tensor_unit:
  fixes U :: 'a::finite update  _
  assumes is_unit_register U
  shows I :: 'b::finite update  ('a*'b) update. iso_register I
  (* Can we show that I = (λx. tensor_op id_cblinfun x) ? It would be nice but I do not see how to prove it. *)
proof -
  have equivalent_registers (id :: 'b update  _) (complement id; id)
    using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
  then obtain J :: 'b update  ((('b, 'b) complement_domain * 'b) update) where iso_register J
    using equivalent_registers_def iso_register_inv by blast
  moreover obtain K :: ('b, 'b) complement_domain update  'a update where iso_register K
    using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
  ultimately have iso_register ((K r id) o J)
    by auto
  then show ?thesis   
    by auto
qed

lemma compatible_complement_pair1:
  assumes compatible F G
  shows compatible F (complement (F;G))
  by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)

lemma compatible_complement_pair2:
  assumes [simp]: compatible F G
  shows compatible G (complement (F;G))
proof -
  have compatible (F;G) (complement (F;G))
    by simp
  then have compatible ((F;G) o Snd) (complement (F;G))
    by auto
  then show ?thesis
    by (auto simp: register_pair_Snd)
qed

lemma equivalent_complements:
  assumes complements F G
  assumes equivalent_registers G G'
  shows complements F G'
  apply (rule complementsI)
   apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
  by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)

lemma complements_complement_pair:
  assumes [simp]: compatible F G
  shows complements F (G; complement (F;G))
proof (rule complementsI)
  have equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))
    apply (rule equivalent_registers_assoc)
    by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
  also have equivalent_registers  id
    by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
  finally show iso_register (F;(G;complement (F;G)))
    using equivalent_registers_sym iso_register_equivalent_id by blast
  show compatible F (G;complement (F;G))
    using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
qed

lemma equivalent_registers_complement:
  assumes equivalent_registers F G
  shows equivalent_registers (complement F) (complement G)
proof -
  have complements F (complement F)
    using assms complement_is_complement equivalent_registers_register_left by blast
  with assms have complements G (complement F)
    by (meson complements_sym equivalent_complements)
  then show ?thesis
    by (rule complement_unique)
qed


lemma complements_complement_pair':
  assumes [simp]: compatible F G
  shows complements G (F; complement (F;G))
proof -
  have equivalent_registers (F;G) (G;F)
    apply (rule equivalent_registersI[where I=swap])
    by auto
  then have equivalent_registers (complement (F;G)) (complement (G;F))
    by (rule equivalent_registers_complement)
  then have equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))
    apply (rule equivalent_registers_pair_right[rotated])
    using assms compatible_complement_pair1 by blast
  moreover have complements G (F; complement (G;F))
    apply (rule complements_complement_pair)
    using assms compatible_sym by blast
  ultimately show ?thesis
    by (meson equivalent_complements equivalent_registers_sym)
qed

lemma complements_chain: 
  assumes [simp]: register F register G
  shows complements (F o G) (complement F; F o complement G)
proof (rule complementsI)
  show compatible (F o G) (complement F; F o complement G)
    by auto
  have equivalent_registers (F  G;(complement F;F  complement G)) (F  G;(F  complement G;complement F))
    apply (rule equivalent_registersI[where I=id r swap])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have equivalent_registers  ((F  G;F  complement G);complement F)
    apply (rule equivalent_registersI[where I=assoc])
    by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
  also have equivalent_registers  (F o (G; complement G);complement F)
    by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
        equivalent_registers_sym equivalent_registers_trans register_comp_pair)
  also have equivalent_registers  (F o id;complement F)
    apply (rule equivalent_registers_pair_left, simp)
    apply (rule equivalent_registers_comp, simp)
    by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
  also have equivalent_registers  id
    by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
  finally show iso_register (F  G;(complement F;F  complement G))
    using equivalent_registers_sym iso_register_equivalent_id by blast
qed

lemma complements_Fst_Snd[simp]: complements Fst Snd
  by (auto intro!: complementsI simp: pair_Fst_Snd)

lemma complements_Snd_Fst[simp]: complements Snd Fst
  by (auto intro!: complementsI simp flip: swap_def)

lemma compatible_unit_register[simp]: register F  compatible F unit_register
  using compatible_sym unit_register_compatible unit_register_is_unit_register by blast

lemma complements_id_unit_register[simp]: complements id unit_register
  using complements_sym is_unit_register_def unit_register_is_unit_register by blast

lemma complements_iso_unit_register: iso_register I  is_unit_register U  complements I U
  using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast

lemma iso_register_complement_is_unit_register[simp]:
  assumes iso_register F
  shows is_unit_register (complement F)
  by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)

text Adding support for termis_unit_register F and termcomplements F G to the [@{attribute register}] attribute
lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
lemmas [register_attribute_rule_immediate] = asm_rl[of is_unit_register _]

no_notation cblinfun_compose (infixl "*u" 55)
no_notation tensor_op (infixr "u" 70)

end

Theory Quantum_Extra2

section More derived facts about quantum registers

text This theory contains some derived facts that cannot be placed in theory Quantum_Extra› 
      because they depend on Laws_Complement_Quantum›.

theory Quantum_Extra2
  imports
    Laws_Complement_Quantum
    Quantum
begin

definition empty_var :: 'a::{CARD_1,enum} update  'b::finite update where
  "empty_var a = one_dim_iso a *C id_cblinfun"

lemma is_unit_register_empty_var[register]: is_unit_register empty_var
proof -
  have [simp]: register empty_var
    unfolding register_def empty_var_def
    by (simp add: clinearI scaleC_left.add)
  have [simp]: compatible empty_var id
    by (auto intro!: compatibleI simp: empty_var_def)
  have [simp]: iso_register (empty_var;id)
    by (auto intro!: same_range_equivalent range_eqI[where x=id_cblinfun o _] 
        simp del: id_cblinfun_eq_1 simp flip: iso_register_equivalent_id simp: register_pair_apply)
  show ?thesis
    by (auto intro!: complementsI simp: is_unit_register_def)
qed

instance complement_domain :: (type, type) default ..

end

Theory Pure_States

theory Pure_States
  imports Quantum_Extra2 "HOL-Eisbach.Eisbach"
begin

definition pure_state_target_vector F ηF = (if ket default  range (cblinfun_apply (F (butterfly ηF ηF)))
   then ket default
   else (SOME η'. norm η' = 1  η'  range (cblinfun_apply (F (butterfly ηF ηF)))))

lemma pure_state_target_vector_eqI:
  assumes F (butterfly ηF ηF) = G (butterfly ηG ηG)
  shows pure_state_target_vector F ηF = pure_state_target_vector G ηG
  by (simp add: assms pure_state_target_vector_def)

lemma pure_state_target_vector_ket_default: pure_state_target_vector F ηF = ket default if ket default  range (cblinfun_apply (F (butterfly ηF ηF)))
  by (simp add: pure_state_target_vector_def that)

lemma
  assumes [simp]: ηF  0 register F
  shows pure_state_target_vector_in_range: pure_state_target_vector F ηF  range ((*V) (F (selfbutter ηF))) (is ?range)
    and pure_state_target_vector_norm: norm (pure_state_target_vector F ηF) = 1 (is ?norm)
proof -
  from assms have selfbutter ηF  0
    by (metis butterfly_0_right complex_vector.scale_zero_right inj_selfbutter_upto_phase)
  then have F (selfbutter ηF)  0
    using register_inj[OF register F, THEN injD, where y=0]
    by (auto simp: complex_vector.linear_0)
  then obtain ψ' where ψ': F (selfbutter ηF) *V ψ'  0
    by (meson cblinfun_eq_0_on_UNIV_span complex_vector.span_UNIV)
  have ex: ψ. norm ψ = 1  ψ  range ((*V) (F (selfbutter ηF)))
    apply (rule exI[of _ (F (selfbutter ηF) *V ψ') /C norm (F (selfbutter ηF) *V ψ')])
    using ψ' apply (auto simp add: norm_inverse)
    by (metis cblinfun.scaleC_right rangeI)
  then show ?range
    by (metis (mono_tags, lifting) pure_state_target_vector_def verit_sko_ex')
  show ?norm
    apply (simp add: pure_state_target_vector_def)
    using ex by (metis (mono_tags, lifting) verit_sko_ex')
qed


lemma pure_state_target_vector_correct: 
  assumes [simp]: η  0 register F
  shows F (selfbutter η) *V pure_state_target_vector F η  0
proof -
  obtain ψ where ψ: F (selfbutter η) ψ = pure_state_target_vector F η
    apply atomize_elim
    using pure_state_target_vector_in_range[OF assms]
    by (smt (verit, best) image_iff top_ccsubspace.rep_eq top_set_def)

  define n where n = cinner η η
  then have n  0
    by auto

  have pure_state_target_vector_neq0: pure_state_target_vector F η  0
    using pure_state_target_vector_norm[OF assms]
    by auto

  have F (selfbutter η) *V pure_state_target_vector F η = F (selfbutter η) *V F (selfbutter η) *V ψ
    by (simp add: ψ)
  also have  = n *C F (selfbutter η) *V ψ
    by (simp flip: cblinfun_apply_cblinfun_compose add: register_mult register_scaleC n_def)
  also have  = n *C pure_state_target_vector F η
    by (simp add: ψ)
  also have   0
    using pure_state_target_vector_neq0 n  0
    by auto
  finally show ?thesis
    by -
qed

definition pure_state' F ψ ηF = F (butterfly ψ ηF) *V pure_state_target_vector F ηF

abbreviation pure_state F ψ  pure_state' F ψ (ket default)

nonterminal pure_tensor
syntax "_pure_tensor" :: 'a  'b  pure_tensor  pure_tensor ("_ _ p _" [1000, 0, 0] 1000)
syntax "_pure_tensor2" :: 'a  'b  'c  'd  pure_tensor ("_ _ p _ _" [1000, 0, 1000, 0] 1000)
syntax "_pure_tensor1" :: 'a  'b  pure_tensor
syntax "_pure_tensor_start" :: pure_tensor  'a ("'(_')")

translations
  "_pure_tensor2 F ψ G φ"  "CONST pure_state (F; G) (ψ s φ)"
  "_pure_tensor F ψ (CONST pure_state G φ)"  "CONST pure_state (F; G) (ψ s φ)"
  "_pure_tensor_start x"  "x"

  "_pure_tensor_start (_pure_tensor2 F ψ G φ)"  "CONST pure_state (F; G) (ψ s φ)"
  "_pure_tensor F ψ (_pure_tensor2 G φ H η)"  "_pure_tensor2 F ψ (G;H) (φ s η)"

term (F ψ p G φ p H z)
term pure_state (F; G) (a s b)

lemma register_pair_butterfly_tensor: (F; G) (butterfly (a s b) (c s d)) = F (butterfly a c) oCL G (butterfly b d)
  if [simp]: compatible F G
  by (auto simp: default_prod_def simp flip: tensor_ell2_ket tensor_butterfly register_pair_apply)

lemma pure_state_eqI:
  assumes F (selfbutter ηF) = G (selfbutter ηG)
  assumes F (butterfly ψ ηF) = G (butterfly φ ηG)
  shows pure_state' F ψ ηF = pure_state' G φ ηG
proof -
  from assms(1) have pure_state_target_vector F ηF = pure_state_target_vector G ηG
    by (rule pure_state_target_vector_eqI)
  with assms(2)
  show ?thesis
    unfolding pure_state'_def
    by simp
qed


definition regular_register F  register F  (a. (F; complement F) (selfbutterket default o a) = selfbutterket default)

lemma regular_registerI:
  assumes [simp]: register F
  assumes [simp]: complements F G
  assumes eq: (F; G) (selfbutterket default o a) = selfbutterket default
  shows regular_register F
proof -
  have [simp]: compatible F G
    using assms by (simp add: complements_def)
  from complements F G
  obtain I where cFI: complement F o I = G and iso_register I
    apply atomize_elim
    by (meson Laws_Complement_Quantum.complement_unique equivalent_registers_def equivalent_registers_sym)
  have (F; complement F) (selfbutterket default o I a) = (F; G) (selfbutterket default o a)
    using cFI by (auto simp: register_pair_apply)
  also have  = selfbutterket default
    by (rule eq)
  finally show ?thesis
    unfolding regular_register_def by auto
qed

lemma regular_register_pair:
  assumes [simp]: compatible F G
  assumes regular_register F and regular_register G
  shows regular_register (F;G)
proof -
  have [simp]: bij (F;complement F) bij (G;complement G)
    using assms(1) compatible_def complement_is_complement complements_def iso_register_bij by blast+
  have [simp]: bij ((F;G);complement (F;G))
    using assms(1) complement_is_complement complements_def iso_register_bij pair_is_register by blast
  have [simp]: register F register G
    using assms(1) unfolding compatible_def by auto

  obtain aF where [simp]: inv (F;complement F) (selfbutterket default) = selfbutterket default o aF
    by (metis assms(2) compatible_complement_right invI pair_is_register register_inj regular_register_def)
  obtain aG where [simp]: inv (G;complement G) (selfbutterket default) = selfbutterket default o aG
    by (metis assms(3) complement_is_complement complements_def inj_iff inv_f_f iso_register_inv_comp1 regular_register_def)
  define t1 where t1 = inv ((F;G); complement (F;G)) (selfbutterket default)
  define t2 where t2 = inv (F; (G; complement (F;G))) (selfbutterket default)
  define t3 where t3 = inv (G; (F; complement (F;G))) (selfbutterket default)


  have complements F (G; complement (F;G))
    apply (rule complements_complement_pair)
    by simp
  then have equivalent_registers (complement F) (G; complement (F;G))
    using Laws_Complement_Quantum.complement_unique equivalent_registers_sym by blast
  then obtain I where [simp]: iso_register I and I: (G; complement (F;G)) = complement F o I
    by (metis equivalent_registers_def)
  then have [simp]: register I
    by (meson iso_register_is_register)
  have [simp]: bij (id r I)
    by (rule iso_register_bij, simp)
  have [simp]: inv (id r I) = id r inv I
    by auto

  have t2 = (inv (id r I) o inv (F;complement F)) (selfbutterket default)
    unfolding t2_def I
    apply (subst o_inv_distrib[symmetric]) 
    by (auto simp: pair_o_tensor)
  also have  = (selfbutterket default o inv I aF)
    apply auto
    by (metis iso_register I id_def iso_register_def iso_register_inv register_id register_tensor_apply)
  finally have t2': t2 = selfbutterket default o inv I aF
    by simp

  have *: complements G (F; complement (F;G))
    apply (rule complements_complement_pair')
    by simp
  then have [simp]: compatible G (F; complement (F;G))
    using complements_def by blast
  from * have equivalent_registers (complement G) (F; complement (F;G))
    using complement_unique equivalent_registers_sym by blast
  then obtain J where [simp]: iso_register J and I: (F; complement (F;G)) = complement G o J
    by (metis equivalent_registers_def)
  then have [simp]: register J
    by (meson iso_register_is_register)
  have [simp]: bij (id r J)
    by (rule iso_register_bij, simp)
  have [simp]: inv (id r J) = id r inv J
    by auto

  have t3 = (inv (id r J) o inv (G;complement G)) (selfbutterket default)
    unfolding t3_def I
    apply (subst o_inv_distrib[symmetric]) 
    by (auto simp: pair_o_tensor)
  also have  = (selfbutterket default o inv J aG)
    apply auto
    by (metis iso_register J id_def iso_register_def iso_register_inv register_id register_tensor_apply)
  finally have t3': t3 = selfbutterket default o inv J aG
    by simp

  have *: ((F;G); complement (F;G)) o assoc' = (F; (G; complement (F;G)))
    apply (rule tensor_extensionality3)
    by (auto simp: register_pair_apply  compatible_complement_pair1 compatible_complement_pair2)
  have t2_t1: t2 = assoc t1
    unfolding t1_def t2_def *[symmetric] apply (subst o_inv_distrib)
    by auto

  have *: ((F;G); complement (F;G)) o (swap r id) o assoc' = (G; (F; complement (F;G)))
    apply (rule tensor_extensionality3)
      apply (auto intro!: register_comp register_tensor_is_register pair_is_register complements_complement_pair
        simp: register_pair_apply compatible_complement_pair1)
    by (metis assms(1) cblinfun_assoc_left(1) swap_registers_left)
  have t3_t1: t3 = assoc ((swap r id) t1)
    unfolding t1_def t3_def *[symmetric] apply (subst o_inv_distrib)
    by (auto intro!: bij_comp simp: iso_register_bij o_inv_distrib)

  from t2 = assoc t1 t3 = assoc ((swap r id) t1)
  have *: selfbutterket default o inv J aG =  assoc ((swap r id) (assoc' (selfbutterket default o inv I aF)))
    by (simp add: t2' t3')

  have selfbutterket default o swap (inv J aG) = (id r swap) (selfbutterket default o inv J aG)
    by auto
  also have  = ((id r swap) o assoc o (swap r id) o assoc') (selfbutterket default o inv I aF)
    by (simp add: *)
  also have  = (assoc o swap) (selfbutterket default o inv I aF)
    apply (rule fun_cong[where g=assoc o swap])
    apply (intro tensor_extensionality3 register_comp register_tensor_is_register)
    by auto
  also have  = assoc (inv I aF o selfbutterket default)
    by auto
  finally have *: selfbutterket default o swap (inv J aG) = assoc (inv I aF o selfbutterket default)
    by -

  obtain c where *: selfbutterket (default::'c) o swap (inv J aG) = selfbutterket default o c o selfbutterket default
    apply atomize_elim
    apply (rule overlapping_tensor)
    using * unfolding assoc_ell2_sandwich sandwich_def
    by auto

  have t1 = ((swap r id) o assoc') t3
    by (simp add: t3_t1 register_tensor_distrib[unfolded o_def, THEN fun_cong] flip: id_def)
  also have  = ((swap r id) o assoc' o (id r swap)) (selfbutterket (default::'c) o swap (inv J aG))
    unfolding t3' by auto
  also have  = ((swap r id) o assoc' o (id r swap)) (selfbutterket default o c o selfbutterket default)
    unfolding * by simp
  also have  = selfbutterket default o c
    apply (simp del: tensor_butterfly)
    by (simp add: default_prod_def)
  finally have t1 = selfbutterket default o c
    by -

  then show ?thesis
    apply (auto intro!: exI[of _ c] simp: regular_register_def t1_def)
    by (metis bij ((F;G);complement (F;G)) bij_inv_eq_iff)
qed

lemma regular_register_comp: regular_register (F o G) if regular_register F regular_register G
proof -
  have [simp]: register F register G
    using regular_register_def that by blast+
  from that obtain a where a: (F; complement F) (selfbutterket default o a) = selfbutterket default
    unfolding regular_register_def by metis
  from that obtain b where b: (G; complement G) (selfbutterket default o b) = selfbutterket default
    unfolding regular_register_def by metis
  have complements (F o G) (complement F; F o complement G)
    by (simp add: complements_chain)
  then have equivalent_registers (complement F; F o complement G) (complement (F o G))
    using complement_unique by blast
  then obtain J where [simp]: iso_register J and 1: (complement F; F o complement G) o J = (complement (F o G))
    using equivalent_registers_def by blast
  have [simp]: register J
    by (simp add: iso_register_is_register)

  define c where c = inv J (a o b)

  have ((F o G); complement (F o G)) (selfbutterket default o c) = ((F o G); (complement F; F o complement G)) (selfbutterket default o J c)
    by (auto simp flip: 1 simp: register_pair_apply)
  also have  = ((F o (G; complement G); complement F) o assoc' o (id r swap)) (selfbutterket default o J c)
    apply (subst register_comp_pair[symmetric])
      apply auto[2]
    apply (subst pair_o_assoc')
       apply auto[3]
    apply (subst pair_o_tensor)
    by auto
  also have  = ((F o (G; complement G); complement F) o assoc') (selfbutterket default o swap (J c))
    by auto
  also have  = ((F o (G; complement G); complement F) o assoc') (selfbutterket default o (b o a))
    unfolding c_def apply (subst surj_f_inv_f[where f=J])
     apply (meson iso_register J bij_betw_inv_into_right iso_register_inv_comp1 iso_register_inv_comp2 iso_tuple_UNIV_I o_bij surj_iff_all)
    by auto
  also have  = (F  (G;complement G);complement F) ((selfbutterket default o b) o a)
    by (simp add: assoc'_apply)
  also have  = (F; complement F) ((G;complement G) (selfbutterket default o b) o a)
    by (simp add: register_pair_apply')
  also have  = selfbutterket default
    by (auto simp: a b) 
  finally have (F  G;complement (F  G)) (selfbutterket default o c) = selfbutterket default
    by -
  then show ?thesis
    using register F register G register_comp regular_register_def by blast
qed

lemma regular_iso_register:
  assumes regular_register F
  assumes [register]: iso_register F
  shows F (selfbutterket default) = selfbutterket default
proof -
  from assms(1) obtain a where a: (F;complement F) (selfbutterket default o a) = selfbutterket default
    using regular_register_def by blast

  let ?u = empty_var :: (unit ell2 CL unit ell2)  _
  have is_unit_register ?u and is_unit_register (complement F)
    by auto
  then have equivalent_registers (complement F) ?u
    using unit_register_unique by blast
  then obtain I where iso_register I and complement F = ?u o I
    by (metis is_unit_register (complement F) equivalent_registers_def is_unit_register_empty_var unit_register_unique)
  have selfbutterket default = (F; ?u o I) (selfbutterket default o a)
    using complement F = empty_var  I a by presburger
  also have  = (F; ?u) (selfbutterket default o I a)
    by (metis Laws_Quantum.register_pair_apply complement F = empty_var  I equivalent_registers (complement F) empty_var assms(2) comp_apply complement_is_complement complements_def equivalent_complements iso_register_is_register)
  also have  = (F; ?u) (selfbutterket default o (one_dim_iso (I a) *C id_cblinfun))
    by simp
  also have  = one_dim_iso (I a) *C (F; ?u) (selfbutterket default o id_cblinfun)
    by (simp add: Axioms_Quantum.register_pair_apply empty_var_def iso_register_is_register)
  also have  = one_dim_iso (I a) *C F (selfbutterket default)
    by (auto simp: register_pair_apply iso_register_is_register simp del: id_cblinfun_eq_1)
  finally have F: one_dim_iso (I a) *C F (selfbutterket default) = selfbutterket default
    by simp

  from F have one_dim_iso (I a)  (0::complex)
    by (metis butterfly_apply butterfly_scaleC_left complex_vector.scale_eq_0_iff id_cblinfun_eq_1 id_cblinfun_not_0 cinner_ket_same ket_nonzero one_dim_iso_of_one one_dim_iso_of_zero')

  have selfbutterket default = one_dim_iso (I a) *C F (selfbutterket default)
    using F by simp
  also have  = one_dim_iso (I a) *C F (selfbutterket default oCL selfbutterket default)
    by auto
  also have  = one_dim_iso (I a) *C (F (selfbutterket default) oCL F (selfbutterket default))
    by (simp add: assms(2) iso_register_is_register register_mult)
  also have  = one_dim_iso (I a) *C ((selfbutterket default /C one_dim_iso (I a)) oCL (selfbutterket default /C one_dim_iso (I a)))
    by (metis (no_types, lifting) F one_dim_iso (I a)  0 complex_vector.scale_left_imp_eq inverse_1 left_inverse scaleC_scaleC zero_neq_one)
  also have  = one_dim_iso (I a) *C selfbutterket default
    by (smt (verit, best) butterfly_comp_butterfly calculation cblinfun_compose_scaleC_left cblinfun_compose_scaleC_right complex_vector.scale_cancel_left cinner_ket_same left_inverse scaleC_one scaleC_scaleC)
  finally have one_dim_iso (I a) = (1::complex)
    by (metis butterfly_0_left butterfly_apply complex_vector.scale_cancel_right cinner_ket_same ket_nonzero scaleC_one)
  with F show F (selfbutterket default) = selfbutterket default
    by simp
qed

lemma pure_state_nested:
  assumes [simp]: compatible F G
  assumes regular_register H
  assumes iso_register H
  shows pure_state (F;G) (pure_state H h s g) = pure_state ((F o H);G) (h s g)
proof -
  note [[simproc del: Laws_Quantum.compatibility_warn]]
  have [simp]: register H
    by (meson assms(3) iso_register_is_register)
  have [simp]: H (selfbutterket default) = selfbutterket default
    apply (rule regular_iso_register)
    using assms by auto
  have 1: pure_state_target_vector H (ket default) = ket default
    apply (rule pure_state_target_vector_ket_default)
    apply auto
    by (metis (no_types, lifting) cinner_ket_same rangeI scaleC_one)

  have butterfly (pure_state H h) (ket default) = butterfly (H (butterfly h (ket default)) *V ket default) (ket default)
    by (simp add: pure_state'_def 1)
  also have  = H (butterfly h (ket default)) oCL selfbutterket default
    by (metis (no_types, opaque_lifting) adj_cblinfun_compose butterfly_adjoint butterfly_comp_cblinfun double_adj)
  also have  = H (butterfly h (ket default)) oCL H (selfbutterket default)
    by simp
  also have  = H (butterfly h (ket default) oCL selfbutterket default)
    by (meson register H register_mult)
  also have  = H (butterfly h (ket default))
    by auto
  finally have 2: butterfly (pure_state H h) (ket default) = H (butterfly h (ket default))
    by simp

  show ?thesis
    apply (rule pure_state_eqI)
    using 1 2
    by (auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def simp flip: tensor_ell2_ket)
qed

lemma state_apply1: 
  assumes [register]: compatible F G
  shows F U *V (F ψ p G φ) = (F (U ψ) p G φ)
proof -
  have [register]: compatible F G
    using assms(1) complements_def by blast
  have F U *V (F ψ p G φ) = (F;G) (U o id_cblinfun) *V (F ψ p G φ)
    apply (subst register_pair_apply)
    by auto
  also have  = (F (U ψ) p G φ)
    unfolding pure_state'_def 
    by (auto simp: register_mult' cblinfun_comp_butterfly tensor_op_ell2)
  finally show ?thesis
    by -
qed

lemma Fst_regular[simp]: regular_register Fst
  apply (rule regular_registerI[where a=selfbutterket default and G=Snd])
  by (auto simp: pair_Fst_Snd default_prod_def)

lemma Snd_regular[simp]: regular_register Snd
  apply (rule regular_registerI[where a=selfbutterket default and G=Fst])
    apply auto[2]
  apply (auto simp only: default_prod_def swap_apply simp flip: swap_def)
  by auto

lemma id_regular[simp]: regular_register id
  apply (rule regular_registerI[where G=unit_register and a=id_cblinfun])
  by (auto simp: register_pair_apply)

lemma swap_regular[simp]: regular_register swap
  by (auto intro!: regular_register_pair simp: swap_def)

lemma assoc_regular[simp]: regular_register assoc
  by (auto intro!: regular_register_pair regular_register_comp simp: assoc_def)

lemma assoc'_regular[simp]: regular_register assoc'
  by (auto intro!: regular_register_pair regular_register_comp simp: assoc'_def)

lemma cspan_pure_state': 
  assumes iso_register F
  assumes cspan (g ` X) = UNIV
  assumes η_cond: F (selfbutter η) *V pure_state_target_vector F η  0
  shows cspan ((λz. pure_state' F (g z) η) ` X) = UNIV
proof -
  from iso_register_decomposition[of F]
  obtain U where [simp]: unitary U and F: F = sandwich U
    using assms(1) by blast

  define η' c where η' = pure_state_target_vector F η and c = cinner (U *V η) η'

  from η_cond
  have c  0
    by (simp add: η'_def F sandwich_def c_def cinner_adj_right)

  have cspan ((λz. pure_state' F (g z) η) ` X) = cspan ((λz. F (butterfly (g z) η) *V η') ` X)
    by (simp add: η'_def pure_state'_def)
  also have  = cspan ((λz. (butterfly (U *V g z) (U *V η)) *V η') ` X)
    by (simp add: F sandwich_def cinner_adj_right)
  also have  = cspan ((λz. c *C U *V g z) ` X)
    by (simp add: c_def)
  also have  = (λz. c *C U *V z) ` cspan (g ` X)
    apply (subst complex_vector.linear_span_image[symmetric])
    by (auto simp: image_image)
  also have  = (λz. c *C U *V z) ` UNIV
    using assms(2) by presburger
  also have  = UNIV
    apply (rule surjI[where f=λz. (U* *V z) /C c])
    using c  0 by (auto simp flip: cblinfun_apply_cblinfun_compose)
  finally show ?thesis
    by -
qed

lemma cspan_pure_state: 
  assumes [simp]: iso_register F
  assumes cspan (g ` X) = UNIV
  shows cspan ((λz. pure_state F (g z)) ` X) = UNIV
  apply (rule cspan_pure_state')
  using assms apply auto[2]
  apply (rule pure_state_target_vector_correct)
  by (auto simp: iso_register_is_register)

lemma pure_state_bounded_clinear:
  assumes [register]: compatible F G
  shows bounded_clinear (λψ. (F ψ p G φ))
proof -
  have [bounded_clinear]: bounded_clinear (F;G)
    using assms pair_is_register register_bounded_clinear by blast
  show ?thesis
    unfolding pure_state'_def
    by (auto intro!: bounded_linear_intros)
qed

lemma pure_state_bounded_clinear_right:
  assumes [register]: compatible F G
  shows bounded_clinear (λφ. (F ψ p G φ))
proof -
  have [bounded_clinear]: bounded_clinear (F;G)
    using assms pair_is_register register_bounded_clinear by blast
  show ?thesis
    unfolding pure_state'_def
    by (auto intro!: bounded_linear_intros)
qed

lemma pure_state_clinear:
  assumes [register]: compatible F G
  shows clinear (λψ. (F ψ p G φ))
  using assms bounded_clinear.clinear pure_state_bounded_clinear by blast

method pure_state_flatten_nested =
  (subst pure_state_nested, (auto; fail)[3])+

text The following method pure_state_eq› tries to solve a equality where both sides are of the form
  F11) ⊗p F22) ⊗p … ⊗p Fnn)› by reordering the registers and unfolding nested register pairs.
  (For the unfolding of nested pairs, it is necessary that the corresponding termcompatible F G facts are provable by the simplifier.)

  If the some of the pure states termψi themselves are p-tensors, they will be flattened if possible. 
  (If all necessary conditions can be proven, such as regular_register› etc.)

  The method may either succeed, fail, or reduce the equality to a hopefully simpler one.

method pure_state_eq =
  (pure_state_flatten_nested?,
    rule pure_state_eqI;
    auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def
    simp flip: tensor_ell2_ket)

lemma example:
  fixes F :: bit update  'c::{finite,default} update
    and G :: bit update  'c update
  assumes [register]: compatible F G
  shows  (F;G) CNOT oCL (G;F) CNOT oCL (F;G) CNOT = (F;G) swap_ell2
proof -
  define Z where Z = complement (F;G)
  then have [register]: compatible Z F compatible Z G
    using assms compatible_complement_pair1 compatible_complement_pair2 compatible_sym by blast+

  have [simp]: iso_register (F;(G;Z))
    using Z_def assms complements_complement_pair complements_def by blast

  have eq1: ((F;G) CNOT oCL (G;F) CNOT oCL (F;G) CNOT) *V (F(ket f) p G(ket g) p Z(ket z))
           = (F;G) swap_ell2 *V (F(ket f) p G(ket g) p Z(ket z)) for f g z
  proof -
    have (F(ket f) p G(ket g) p Z(ket z)) = ((F;G) (ket f s ket g) p Z(ket z))
      by pure_state_eq
    also have (F;G) CNOT *V  = ((F;G) (ket f s ket (g+f)) p Z(ket z))
      apply (subst state_apply1) by auto
    also have  = ((G;F) (ket (g+f) s ket f) p Z(ket z))
      by pure_state_eq
    also have (G;F) CNOT *V  = ((G;F) (ket (g+f) s ket g) p Z ket z)
      apply (subst state_apply1) by auto
    also have  = ((F;G) (ket g s ket (g+f)) p Z ket z)
      by pure_state_eq
    also have (F;G) CNOT *V  = ((F;G) ket g s ket f p Z ket z)
      apply (subst state_apply1)
      apply simp
      using add_right_imp_eq by fastforce
    also have  = (F(ket g) p G(ket f) p Z(ket z))
      by pure_state_eq
    finally have 1: ((F;G) CNOT oCL (G;F) CNOT oCL (F;G) CNOT) *V (F(ket f) p G(ket g) p Z(ket z)) = (F(ket g) p G(ket f) p Z(ket z))
      by auto

    have (F(ket f) p G(ket g) p Z(ket z)) = ((F;G) (ket f s ket g) p Z(ket z))
      by pure_state_eq
    also have (F;G) swap_ell2 *V  = ((F;G) (ket g s ket f) p Z(ket z))
      by (auto simp: state_apply1 swap_ell2_tensor simp del: tensor_ell2_ket)
    also have  = (F(ket g) p G(ket f) p Z(ket z))
      by pure_state_eq
    finally have 2: (F;G) swap_ell2 *V (F(ket f) p G(ket g) p Z(ket z)) = (F(ket g) p G(ket f) p Z(ket z))
      by -

    from 1 2 show ?thesis
      by simp
  qed

  then have eq1: ((F;G) CNOT oCL (G;F) CNOT oCL (F;G) CNOT) *V ψ
           = (F;G) swap_ell2 *V ψ if ψ  {(F(ket f) p G(ket g) p Z(ket z))| f g z. True} for ψ
    using that by auto

  moreover have cspan {(F(ket f) p G(ket g) p Z(ket z))| f g z. True} = UNIV
    apply (simp only: double_exists setcompr_eq_image full_SetCompr_eq)
    apply simp
    apply (rule cspan_pure_state)
    by auto

  ultimately show ?thesis
    using cblinfun_eq_on_UNIV_span by blast
qed

end